diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-11-27 13:24:01 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2017-12-07 14:39:56 +0000 |
commit | 24841386cff6fdccc11accf9daa815c2c7444d65 (patch) | |
tree | d9113a9f69d6750ae04548c44415f52327a3e2ee /haddock-api/src/Haddock/Backends | |
parent | 30a25af805d1f067129b31a2ff9f0c8536768a4d (diff) |
Track changes to follow Trac #14529
This tracks the refactoring of HsDecl.ConDecl.
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 7 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 74 | ||||
-rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 38 |
3 files changed, 26 insertions, 93 deletions
diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index f1d8ddb2..ee81a83c 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -231,7 +231,7 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap - = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) + = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConArgs con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] @@ -252,15 +252,14 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] -ppCtor dflags _dat subdocs con@ConDeclGADT {} +ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where - f = [typeSig name (hsib_body $ con_type con)] + f = [typeSig name (getGADTConType con)] typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con - ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index d79e0e6c..793e40d8 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -631,7 +631,7 @@ ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX -> LConDecl DocNameI -> LaTeX ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = leader <-> - case con_details con of + case con_args con of PrefixCon args -> decltt (hsep ((header_ unicode <+> ppOcc) : @@ -660,8 +660,8 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = ppOcc = case occ of [one] -> ppBinder one _ -> cat (punctuate comma (map ppBinder occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) + context = unLoc (fromMaybe (noLoc []) (con_mb_cxt con)) -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. @@ -672,7 +672,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = leader <-> - doGADTCon (hsib_body $ con_type con) + doGADTCon (getGADTConType con) where doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> @@ -690,72 +690,6 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = [] -> panic "empty con_names" (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst -{- old - -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocName -> LaTeX -ppSideBySideConstr subdocs unicode leader (L loc con) = - leader <-> - case con_res con of - ResTyH98 -> case con_details con of - - PrefixCon args -> - decltt (hsep ((header_ unicode <+> ppOcc) : - map (ppLParendType unicode) args)) - <-> rDoc mbDoc <+> nl - - RecCon (L _ fields) -> - (decltt (header_ unicode <+> ppOcc) - <-> rDoc mbDoc <+> nl) - $$ - doRecordFields fields - - InfixCon arg1 arg2 -> - decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, - ppOcc, - ppLParendType unicode arg2 ]) - <-> rDoc mbDoc <+> nl - - ResTyGADT _ resTy -> case con_details con of - -- prefix & infix could also use hsConDeclArgTys if it seemed to - -- simplify the code. - PrefixCon args -> doGADTCon args resTy - cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ - doRecordFields fields - InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy - - where - doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - - doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode (mk_forall $ mk_phi $ - foldr mkFunTy resTy args) - ) <-> rDoc mbDoc - - - header_ = ppConstrHdr (con_explicit con) tyVars context - occ = map (nameOccName . getName . unLoc) $ con_names con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - ltvs = con_qvars con - tyVars = tyvarNames (con_qvars con) - context = unLoc (con_cxt con) - - mk_forall ty | con_explicit con = L loc (HsForAllTy (hsQTvExplicit ltvs) ty) - | otherwise = ty - mk_phi ty | null context = ty - | otherwise = L loc (HsQualTy (con_cxt con) ty) - - -- don't use "con_doc con", in case it's reconstructed from a .hi file, - -- or also because we want Haddock to do the doc-parsing, not GHC. - mbDoc = case con_names con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst - mkFunTy a b = noLoc (HsFunTy a b) --} ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 3b85f96c..bf71fec4 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -769,7 +769,7 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- incorporated into the declaration ppShortConstrParts :: Bool -> Bool -> ConDecl DocNameI -> Unicode -> Qualification -> (Html, Html, Html) ppShortConstrParts summary dataInst con unicode qual = case con of - ConDeclH98{} -> case con_details con of + ConDeclH98{} -> case con_args con of PrefixCon args -> (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args), noHtml, noHtml) @@ -782,17 +782,18 @@ ppShortConstrParts summary dataInst con unicode qual = case con of ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], noHtml, noHtml) - ConDeclGADT {} -> (ppOcc <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts resTy,noHtml,noHtml) + ConDeclGADT {} -> (ppOcc <+> dcolon unicode + <+> ppLType unicode qual HideEmptyContexts (getGADTConType con) + , noHtml, noHtml) where - resTy = hsib_body (con_type con) - - doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields)) + doRecordFields fields = shortSubDecls dataInst $ + map (ppShortField summary unicode qual) (map unLoc fields) header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of + ppOcc = case occ of [one] -> ppBinder summary one _ -> hsep (punctuate comma (map (ppBinder summary) occ)) @@ -800,9 +801,9 @@ ppShortConstrParts summary dataInst con unicode qual = case con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) - tyVars = tyvarNames ltvs - lcontext = fromMaybe (noLoc []) (con_cxt con) + -- Used for H98 syntax only + tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) + lcontext = fromMaybe (noLoc []) (con_mb_cxt con) context = unLoc lcontext forall_ = False @@ -827,7 +828,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) where decl = case con of - ConDeclH98{} -> case con_details con of + ConDeclH98{} -> case con_args con of PrefixCon args -> hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual HideEmptyContexts) args) @@ -841,11 +842,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ppLParendType unicode qual HideEmptyContexts arg2] <+> fixity - ConDeclGADT{} -> doGADTCon resTy - - resTy = hsib_body (con_type con) + ConDeclGADT{} -> doGADTCon (getGADTConType con) - fieldPart = case getConDetails con of + fieldPart = case getConArgs con of RecCon (L _ fields) -> [doRecordFields fields] _ -> [] @@ -860,9 +859,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ getConNames con + occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of + ppOcc = case occ of [one] -> ppBinder False one _ -> hsep (punctuate comma (map (ppBinder False) occ)) @@ -870,8 +869,9 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) - context = unLoc (fromMaybe (noLoc []) (con_cxt con)) + -- Used for H98 syntax only + tyVars = map (getName . hsLTyVarName) (con_ex_tvs con) + context = unLoc (fromMaybe (noLoc []) (con_mb_cxt con)) forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. |