From aaf07338cbfec7df69532a4d1e8a0f21c9a1cfde Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Mon, 4 Dec 2017 13:07:23 -0500 Subject: Bump GHC version --- haddock-api/src/Haddock/InterfaceFile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 76bcb4ae..a4e9eb3c 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -82,7 +82,7 @@ binaryInterfaceMagic = 0xD0Cface -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16 -#if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) +#if (__GLASGOW_HASKELL__ >= 805) && (__GLASGOW_HASKELL__ < 807) binaryInterfaceVersion = 32 binaryInterfaceVersionCompatibility :: [Word16] -- cgit v1.2.3 From 24841386cff6fdccc11accf9daa815c2c7444d65 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Mon, 27 Nov 2017 13:24:01 +0000 Subject: Track changes to follow Trac #14529 This tracks the refactoring of HsDecl.ConDecl. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 7 ++- haddock-api/src/Haddock/Backends/LaTeX.hs | 74 ++------------------------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 38 ++++++------- haddock-api/src/Haddock/Convert.hs | 26 ++++----- haddock-api/src/Haddock/GhcUtils.hs | 31 ++++++++++- haddock-api/src/Haddock/Interface/Create.hs | 16 +++--- haddock-api/src/Haddock/Interface/Rename.hs | 46 +++++++++------- haddock-api/src/Haddock/Utils.hs | 20 +------ 8 files changed, 105 insertions(+), 153 deletions(-) (limited to 'haddock-api/src/Haddock') 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. diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fc808568..37fad036 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -284,10 +284,6 @@ synifyDataCon use_gadt_syntax dc = -- con_qvars means a different thing depending on gadt-syntax (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc - qvars = if use_gadt_syntax - then synifyTyVars (univ_tvs ++ ex_tvs) - else synifyTyVars ex_tvs - -- skip any EqTheta, use 'orig'inal syntax ctx = synifyCtx theta @@ -310,21 +306,25 @@ synifyDataCon use_gadt_syntax dc = (False,True) -> case linear_tys of [a,b] -> return $ InfixCon a b _ -> Left "synifyDataCon: infix with non-2 args?" - gadt_ty = HsIB [] (synifyType WithinType res_ty) False -- finally we get synifyDataCon's result! in hs_arg_tys >>= \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_names = [name] - , con_type = gadt_ty - , con_doc = Nothing } + ConDeclGADT { con_names = [name] + , con_forall = True + , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) + , con_mb_cxt = Just ctx + , con_args = hat + , con_res_ty = synifyType WithinType res_ty + , con_doc = Nothing } else return $ noLoc $ - ConDeclH98 { con_name = name - , con_qvars = Just qvars - , con_cxt = Just ctx - , con_details = hat - , con_doc = Nothing } + ConDeclH98 { con_name = name + , con_forall = True + , con_ex_tvs = map synifyTyVar ex_tvs + , con_mb_cxt = Just ctx + , con_args = hat + , con_doc = Nothing } synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index a1009c1f..4963d2f8 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -17,6 +17,7 @@ module Haddock.GhcUtils where import Control.Arrow +import Haddock.Types( DocNameI ) import Exception import Outputable @@ -148,6 +149,32 @@ nubByName f ns = go emptyNameSet ns where y = f x +getGADTConType :: ConDecl p -> LHsType p +-- The full type of a GADT data constructor We really only get this in +-- order to pretty-print it, and currently only in Haddock's code. So +-- we are cavalier about locations and extensions, hence the +-- 'undefined's +getGADTConType (ConDeclGADT { con_forall = has_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty }) + | has_forall = noLoc (HsForAllTy { hst_bndrs = hsQTvExplicit qtvs + , hst_body = theta_ty }) + | otherwise = theta_ty + where + theta_ty | Just theta <- mcxt + = noLoc (HsQualTy { hst_ctxt = theta, hst_body = tau_ty }) + | otherwise + = tau_ty + + tau_ty = case args of + RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty) + PrefixCon pos_args -> foldr (\ a b -> noLoc (HsFunTy a b)) res_ty pos_args + InfixCon {} -> panic "InfixCon for GADT" + +getGADTConType (ConDeclH98 {}) = panic "getGADTConType" + -- Should only be called on ConDeclGADT + ------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- @@ -179,7 +206,7 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = - case getConDetails con of + case con_args con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] @@ -259,3 +286,5 @@ setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f + + diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 27456998..52a983a8 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -61,7 +61,7 @@ import TcRnTypes import FastString (concatFS) import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O -import HsDecls ( getConDetails ) +import HsDecls ( getConArgs ) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -455,7 +455,7 @@ subordinates instMap decl = case decl of constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) - | RecCon flds <- map getConDetails cons + | RecCon flds <- map getConArgs cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) @@ -1028,7 +1028,7 @@ extractDecl name decl let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) - , RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d)) + , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns , selectorFieldOcc n == name @@ -1050,14 +1050,14 @@ extractPatternSyn nm t tvs cons = extract :: ConDecl GhcRn -> Sig GhcRn extract con = let args = - case getConDetails con of + case getConArgs 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) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) _ -> typ typ'' = noLoc (HsQualTy (noLoc []) typ') in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') @@ -1066,7 +1066,7 @@ extractPatternSyn nm t tvs cons = longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs data_ty con - | ConDeclGADT{} <- con = hsib_body $ con_type con + | ConDeclGADT{} <- con = con_res_ty con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] @@ -1074,7 +1074,7 @@ extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = - case getConDetails con of + case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest @@ -1084,7 +1084,7 @@ extractRecSel nm t tvs (L _ con : rest) = , L l n <- ns, selectorFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty - | ConDeclGADT{} <- con = hsib_body $ con_type con + | ConDeclGADT{} <- con = con_res_ty con | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 7023a908..fadd0553 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -428,35 +428,41 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_derivs = noLoc [] }) renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) -renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details +renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars + , con_mb_cxt = lcontext, con_args = details , con_doc = mbldoc }) = do lname' <- renameL lname - ltyvars' <- traverse renameLHsQTyVars ltyvars + ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' - , con_details = details', con_doc = mbldoc' }) + return (decl { con_name = lname', con_ex_tvs = ltyvars' + , con_mb_cxt = lcontext' + , con_args = details', con_doc = mbldoc' }) - where - renameDetails (RecCon (L l fields)) = do - fields' <- mapM renameConDeclFieldField fields - return (RecCon (L l fields')) - renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps - renameDetails (InfixCon a b) = do - a' <- renameLType a - b' <- renameLType b - return (InfixCon a' b') - -renameCon decl@(ConDeclGADT { con_names = lnames - , con_type = lty +renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars + , con_mb_cxt = lcontext, con_args = details + , con_res_ty = res_ty , con_doc = mbldoc }) = do lnames' <- mapM renameL lnames - lty' <- renameLSigType lty + ltyvars' <- renameLHsQTyVars ltyvars + lcontext' <- traverse renameLContext lcontext + details' <- renameDetails details + res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames' - , con_type = lty', con_doc = mbldoc' }) + return (decl { con_names = lnames', con_qvars = ltyvars' + , con_mb_cxt = lcontext', con_args = details' + , con_res_ty = res_ty', con_doc = mbldoc' }) + +renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) +renameDetails (RecCon (L l fields)) = do + fields' <- mapM renameConDeclFieldField fields + return (RecCon (L l fields')) +renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps +renameDetails (InfixCon a b) = do + a' <- renameLType a + b' <- renameLType b + return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField names t doc)) = do diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 84f58ab8..1993fb5d 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -180,33 +180,17 @@ restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = - case getConDetails h98d of + case con_args d of PrefixCon _ -> Just d RecCon fields | all field_avail (unL fields) -> Just d - | otherwise -> Just (h98d { con_details = PrefixCon (field_types (map unL (unL fields))) }) + | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where - h98d = h98ConDecl d - h98ConDecl c@ConDeclH98{} = c - h98ConDecl c@ConDeclGADT{} = c' - where - (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl GhcRn - c' = ConDeclH98 - { con_name = head (con_names c) - , con_qvars = Just $ HsQTvs { hsq_implicit = mempty - , hsq_explicit = tvs - , hsq_dependent = emptyNameSet } - , con_cxt = Just cxt - , con_details = details - , con_doc = con_doc c - } - field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs -- cgit v1.2.3 From b9bf41f6a25239bb2c0780d146ba1f18c061d6d3 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 6 Jan 2018 08:20:43 -0800 Subject: Pass to GHC visible modules for instance filtering The GHC-side `getNameToInstancesIndex` filters out incorrectly some instances because it is not aware of what modules are visible. On the Haddock side, we need to pass in the modules we are processing. On the GHC side, we need to check against _those_ modules when checking if an instance is visible. --- haddock-api/src/Haddock/Interface/AttachInstances.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 2231ce7e..4fd9d264 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -54,7 +54,7 @@ type ExportInfo = (ExportedNames, Modules) -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] attachInstances expInfo ifaces instIfaceMap = do - (_msgs, mb_index) <- getNameToInstancesIndex + (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where -- TODO: take an IfaceMap as input -- cgit v1.2.3 From aa33be50e6292875b6afea8f97980c3a6e76ed87 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Sat, 13 Jan 2018 03:12:37 -0800 Subject: Constructor and pattern synonym argument docs (#709) * Support Haddocks on constructor arguments This is in conjunction with https://phabricator.haskell.org/D4094. Adds support for rendering Haddock's on (non-record) constructor arguments, both for regular and GADT constructors. * Support haddocks on pattern synonym arguments It appears that GHC already parsed these - we just weren't using them. In the process of doing this, I tried to deduplicate some code around handling patterns. * Update the markup guide Add some information about the new support for commenting constructor arguments, and mention pattern synonyms and GADT-style constructors. * Overhaul LaTeX support for data/pattern decls This includes at least * fixing several bugs that resulted in invalid LaTeX * fixing GADT data declaration headers * overhaul handling of record fields * overhaul handling of GADT constructors * overhaul handling of bundled patterns * add support for constructor argument docs * Support GADT record constructors This means changes what existing HTML docs look like. As for LaTeX, looks like GADT records were never even supported. Now they are. * Clean up code/comments Made code/comments consistent between the LaTeX and XHTML backend when possible. * Update changelog * Patch post-rebase regressions * Another post-rebase change We want return values to be documentable on record GADT constructors. --- CHANGES.md | 3 + doc/markup.rst | 14 + haddock-api/src/Haddock/Backends/LaTeX.hs | 483 ++++++++++++++---------- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 401 +++++++++++++------- haddock-api/src/Haddock/Backends/Xhtml/Utils.hs | 4 +- haddock-api/src/Haddock/Interface/Create.hs | 43 ++- 6 files changed, 595 insertions(+), 353 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/CHANGES.md b/CHANGES.md index f4602e85..9ba8be07 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -22,6 +22,9 @@ * Overhaul Haddock's rendering of kind signatures so that invisible kind parameters are not printed (#681) (Fixes #544) + * Overhaul handling of data declarations in XHTML and LaTeX. Adds support for + documenting individual arguments of constructors/patterns (#709) + ## Changes in version 2.18.1 * Synopsis is working again (#599) diff --git a/doc/markup.rst b/doc/markup.rst index d0b9392d..4d56cc83 100644 --- a/doc/markup.rst +++ b/doc/markup.rst @@ -39,6 +39,8 @@ the following: - A ``data`` declaration, +- A ``pattern`` declaration, + - A ``newtype`` declaration, - A ``type`` declaration @@ -117,6 +119,15 @@ Constructors are documented like so: :: or like this: :: + data T a b + = C1 -- ^ This is the documentation for the 'C1' constructor + a -- ^ This is the documentation for the argument of type 'a' + b -- ^ This is the documentation for the argument of type 'b' + +There is one edge case that is handled differently: only one ``-- ^`` +annotation occuring after the constructor and all its arguments is +applied to the constructor, not its last argument: :: + data T a b = C1 a b -- ^ This is the documentation for the 'C1' constructor | C2 a b -- ^ This is the documentation for the 'C2' constructor @@ -164,6 +175,9 @@ Individual arguments to a function may be documented like this: :: -> Float -- ^ The 'Float' argument -> IO () -- ^ The return value +Pattern synonyms and GADT-style data constructors also support this +style of documentation. + .. _module-description: The Module Description diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 793e40d8..51e183c7 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -179,13 +179,14 @@ string_txt (PStr s1) s2 = unpackFS s1 ++ s2 string_txt (ZStr s1) s2 = zString s1 ++ s2 string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 - +-- | Prints out an entry in a module export list. exportListItem :: ExportItem DocNameI -> LaTeX exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } - = sep (punctuate comma . map ppDocBinder $ declNames decl) <> - case subdocs of - [] -> empty - _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) + = let (leader, names) = declNames decl + in sep (punctuate comma [ leader <+> ppDocBinder name | name <- names ]) <> + case subdocs of + [] -> empty + _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) exportListItem (ExportNoDecl y []) = ppDocBinder y exportListItem (ExportNoDecl y subs) @@ -249,13 +250,17 @@ ppDocGroup lev doc = sec lev <> braces doc sec _ = text "\\paragraph" -declNames :: LHsDecl DocNameI -> [DocName] +-- | Given a declaration, extract out the names being declared +declNames :: LHsDecl DocNameI + -> ( LaTeX -- ^ to print before each name in an export list + , [DocName] -- ^ names being declared + ) declNames (L _ decl) = case decl of - TyClD d -> [tcdName d] - SigD (TypeSig lnames _ ) -> map unLoc lnames - SigD (PatSynSig lnames _) -> map unLoc lnames - ForD (ForeignImport (L _ n) _ _ _) -> [n] - ForD (ForeignExport (L _ n) _ _ _) -> [n] + TyClD d -> (empty, [tcdName d]) + SigD (TypeSig lnames _ ) -> (empty, map unLoc lnames) + SigD (PatSynSig lnames _) -> (text "pattern", map unLoc lnames) + ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) + ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -278,47 +283,44 @@ moduleBasename mdl = map (\c -> if c == '.' then '-' else c) -- * Decls ------------------------------------------------------------------------------- - -ppDecl :: LHsDecl DocNameI - -> [(HsDecl DocNameI, DocForDecl DocName)] - -> DocForDecl DocName - -> [DocInstance DocNameI] - -> [(DocName, DocForDecl DocName)] - -> [(DocName, Fixity)] +-- | Pretty print a declaration +ppDecl :: LHsDecl DocNameI -- ^ decl to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ all pattern decls + -> DocForDecl DocName -- ^ documentation for decl + -> [DocInstance DocNameI] -- ^ all instances + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs + -> [(DocName, Fixity)] -- ^ all fixities -> LaTeX -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 pats instances subdocs loc (Just doc) d unicode - TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode +ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of + TyClD d@FamDecl {} -> ppTyFam False doc d unicode + TyClD d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now --- TyClD d@(TySynonym {}) +-- TyClD d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode - SigD (TypeSig lnames t) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) - (hsSigWcType t) unicode - SigD (PatSynSig lnames ty) -> - ppLPatSig loc (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor loc (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD (TypeSig lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD (PatSynSig lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ -> empty + DerivD _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False -ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> +ppTyFam :: Bool -> Documentation DocName -> TyClDecl DocNameI -> Bool -> LaTeX -ppTyFam _ _ _ _ _ = +ppTyFam _ _ _ _ = error "type family declarations are currently not supported by --latex" -ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX -ppFor loc doc (ForeignImport (L _ name) typ _ _) unicode = - ppFunSig loc doc [name] (hsSigType typ) unicode -ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" +ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX +ppFor doc (ForeignImport (L _ name) typ _ _) unicode = + ppFunSig doc [name] (hsSigType typ) unicode +ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -328,18 +330,18 @@ ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- we skip type patterns for now -ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX +ppTySyn :: DocForDecl DocName -> TyClDecl DocNameI -> Bool -> LaTeX -ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars +ppTySyn doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars , tcdRhs = ltype }) unicode - = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : map ppSymName (tyvarNames ltyvars)) full = hdr <+> char '=' <+> ppLType unicode ltype -ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" +ppTySyn _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- @@ -347,61 +349,98 @@ ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> LHsType DocNameI +ppFunSig :: DocForDecl DocName -> [DocName] -> LHsType DocNameI -> Bool -> LaTeX -ppFunSig loc doc docnames (L _ typ) unicode = - ppTypeOrFunSig loc docnames typ doc +ppFunSig doc docnames (L _ typ) unicode = + ppTypeOrFunSig typ doc ( ppTypeSig names typ False , hsep . punctuate comma $ map ppSymName names - , dcolon unicode) + , dcolon unicode + ) unicode where names = map getName docnames -ppLPatSig :: SrcSpan -> DocForDecl DocName -> [DocName] - -> LHsSigType DocNameI - -> Bool -> LaTeX -ppLPatSig _loc (doc, _argDocs) docnames ty unicode - = declWithDoc pref1 (documentationToLaTeX doc) +-- | Pretty-print a pattern synonym +ppLPatSig :: DocForDecl DocName -- ^ documentation + -> [DocName] -- ^ pattern names in the pattern signature + -> LHsSigType DocNameI -- ^ type of the pattern synonym + -> Bool -- ^ unicode + -> LaTeX +ppLPatSig doc docnames ty unicode + = ppTypeOrFunSig typ doc + ( keyword "pattern" <+> ppTypeSig names typ False + , keyword "pattern" <+> (hsep . punctuate comma $ map ppSymName names) + , dcolon unicode + ) + unicode where - pref1 = hsep [ keyword "pattern" - , hsep $ punctuate comma $ map ppDocBinder docnames - , dcolon unicode - , ppLType unicode (hsSigType ty) - ] - -ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocNameI - -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) - -> Bool -> LaTeX -ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) - unicode - | Map.null argDocs = - declWithDoc pref1 (documentationToLaTeX doc) - | otherwise = - declWithDoc pref2 $ Just $ + typ = unLoc (hsSigType ty) + names = map getName docnames + +-- | Pretty-print a type, adding documentation to the whole type and its +-- arguments as needed. +ppTypeOrFunSig :: HsType DocNameI + -> DocForDecl DocName -- ^ documentation + -> ( LaTeX -- ^ first-line (no-argument docs only) + , LaTeX -- ^ first-line (argument docs only) + , LaTeX -- ^ type prefix (argument docs only) + ) + -> Bool -- ^ unicode + -> LaTeX +ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep0) unicode + | Map.null argDocs = declWithDoc pref1 (documentationToLaTeX doc) + | otherwise = declWithDoc pref2 $ Just $ text "\\haddockbeginargs" $$ - do_args 0 sep0 typ $$ + vcat (map (uncurry (<->)) (ppSubSigLike unicode typ argDocs [] sep0)) $$ text "\\end{tabulary}\\par" $$ fromMaybe empty (documentationToLaTeX doc) + +-- This splits up a type signature along `->` and adds docs (when they exist) +-- to the arguments. The output is a list of (leader/seperator, argument and +-- its doc) +ppSubSigLike :: Bool -- ^ unicode + -> HsType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when we have `HsRecTy`) + -> LaTeX -- ^ seperator (beginning of first line) + -> [(LaTeX, LaTeX)] -- ^ arguments (leader/sep, type) +ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ where - do_largs n leader (L _ t) = do_args n leader t - - arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs - - do_args :: Int -> LaTeX -> HsType DocNameI -> LaTeX - do_args _n leader (HsForAllTy tvs ltype) - = decltt leader - <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) - <+> ppLType unicode ltype - do_args n leader (HsQualTy lctxt ltype) - = decltt leader - <-> ppLContextNoArrow lctxt unicode <+> nl $$ - do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy lt r) - = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ - do_largs (n+1) (arrow unicode) r - do_args n leader t - = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs + + do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] + do_args _n leader (HsForAllTy tvs ltype) + = [ ( decltt leader + , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) + <+> ppLType unicode ltype + ) ] + do_args n leader (HsQualTy lctxt ltype) + = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) + : do_largs n (darrow unicode) ltype + + do_args n leader (HsFunTy (L _ (HsRecTy fields)) r) + = [ (decltt ldr, latex <+> nl) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let latex = ppSideBySideField subdocs unicode field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + do_args n leader (HsFunTy lt r) + = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = [ (decltt leader, decltt (ppType unicode t) <-> arg_doc n <+> nl) ] + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "," + gadtEnd = hcat (replicate (if unicode then 3 else 4) (text "\\ ")) <> text "\\}" + gadtOpen = text "\\{" ppTypeSig :: [Name] -> HsType DocNameI -> Bool -> LaTeX @@ -483,10 +522,10 @@ ppFds fds unicode = hsep (map (ppDocName . unLoc) vars2) -ppClassDecl :: [DocInstance DocNameI] -> SrcSpan +ppClassDecl :: [DocInstance DocNameI] -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocNameI -> Bool -> LaTeX -ppClassDecl instances loc doc subdocs +ppClassDecl instances doc subdocs (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ @@ -508,7 +547,7 @@ ppClassDecl instances loc doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc names (hsSigWcType typ) unicode + vcat [ ppFunSig doc names (hsSigWcType typ) unicode | L _ (TypeSig lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] @@ -518,7 +557,7 @@ ppClassDecl instances loc doc subdocs instancesBit = ppDocInstances unicode instances -ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" +ppClassDecl _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" ppDocInstances :: Bool -> [DocInstance DocNameI] -> LaTeX ppDocInstances _unicode [] = empty @@ -567,15 +606,17 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of -- * Data & newtype declarations ------------------------------------------------------------------------------- - -ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -> [DocInstance DocNameI] -> - [(DocName, DocForDecl DocName)] -> SrcSpan -> - Maybe (Documentation DocName) -> TyClDecl DocNameI -> Bool -> - LaTeX -ppDataDecl pats instances subdocs _loc doc dataDecl unicode - - = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) - (if null body then Nothing else Just (vcat body)) +-- | Pretty-print a data declaration +ppDataDecl :: [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, DocForDecl DocName)] -- ^ relevant decl docs + -> Maybe (Documentation DocName) -- ^ this decl's docs + -> TyClDecl DocNameI -- ^ data decl to print + -> Bool -- ^ unicode + -> LaTeX +ppDataDecl pats instances subdocs doc dataDecl unicode = + declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -587,28 +628,26 @@ ppDataDecl pats instances subdocs _loc doc dataDecl unicode (whereBit, leaders) | null cons , null pats = (empty,[]) - | null cons = (decltt (keyword "where"), repeat empty) + | null cons = (text "where", repeat empty) | otherwise = case resTy of - ConDeclGADT{} -> (decltt (keyword "where"), repeat empty) + ConDeclGADT{} -> (text "where", repeat empty) _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing | otherwise = Just $ + text "\\enspace" <+> emph (text "Constructors") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ text "\\end{tabulary}\\par" patternBit - | null cons = Nothing - | otherwise = Just $ + | null pats = Nothing + | otherwise = Just $ + text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ 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 + vcat [ empty <-> ppSideBySidePat lnames typ d unicode + | (SigD (PatSynSig lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" @@ -627,41 +666,100 @@ ppConstrHdr forall tvs ctxt unicode False -> empty -ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX - -> LConDecl DocNameI -> LaTeX -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = - leader <-> - case con_args 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 +-- | Pretty-print a constructor +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -- ^ all decl docs + -> Bool -- ^ unicode + -> LaTeX -- ^ prefix to decl + -> LConDecl DocNameI -- ^ constructor decl + -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> decltt decl <-> rDoc mbDoc <+> nl + $$ fieldPart + where + -- Find the name of a constructors in the decl (`getConName` always returns + -- a non-empty list) + aConName = unLoc (head (getConNames con)) + + occ = map (nameOccName . getName . unLoc) $ getConNames con + + ppOcc = cat (punctuate comma (map ppBinder occ)) + ppOccInfix = cat (punctuate comma (map ppBinderInfix occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs + + -- First line of the constructor (no doc, no fields, single-line) + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon args + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppOcc + , hsep (map (ppLParendType unicode) args) + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ <+> ppOcc + + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ <+> ppOcc + | otherwise -> hsep [ header_ + , ppLParendType unicode arg1 + , ppOccInfix + , ppLParendType unicode arg2 + ] + + ConDeclGADT{} + | hasArgDocs || not (isEmpty fieldPart) -> ppOcc + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLType unicode (getGADTConType con) + ] + + fieldPart = case (con, getConArgs con) of + -- Record style GADTs + (ConDeclGADT{}, RecCon _) -> doConstrArgsWithDocs [] + + -- Regular record declarations + (_, RecCon (L _ fields)) -> doRecordFields fields + + -- Any GADT or a regular H98 prefix data constructor + (_, PrefixCon args) | hasArgDocs -> doConstrArgsWithDocs args + + -- An infix H98 data constructor + (_, InfixCon arg1 arg2) | hasArgDocs -> doConstrArgsWithDocs [arg1,arg2] + + _ -> empty - where doRecordFields fields = - vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) + vcat [ empty <-> tt (text begin) <+> ppSideBySideField subdocs unicode field <+> nl + | (begin, L _ field) <- zip ("\\qquad \\{" : repeat "\\qquad ,") fields + ] + $$ + empty <-> tt (text "\\qquad \\}") <+> nl + doConstrArgsWithDocs args = vcat $ map (\l -> empty <-> text "\\qquad" <+> l) $ case con of + ConDeclH98{} -> + [ decltt (ppLParendType unicode arg) <-> rDoc (fmap _doc mdoc) <+> nl + | (i, arg) <- zip [0..] args + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + [ l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) + ] - header_ = ppConstrHdr False tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - 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. @@ -670,27 +768,8 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = (cn:_) -> lookup (unLoc cn) subdocs >>= fmap _doc . combineDocumentation . fst -ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclGADT {})) = - leader <-> - doGADTCon (getGADTConType con) - - where - doGADTCon resTy = decltt (ppOcc <+> dcolon unicode <+> - ppLType unicode resTy - ) <-> rDoc mbDoc - - occ = map (nameOccName . getName . unLoc) $ getConNames con - ppOcc = case occ of - [one] -> ppBinder one - _ -> cat (punctuate comma (map ppBinder occ)) - - -- 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 getConNames con of - [] -> panic "empty con_names" - (cn:_) -> lookup (unLoc cn) subdocs >>= - fmap _doc . combineDocumentation . fst +-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX ppSideBySideField subdocs unicode (ConDeclField names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) @@ -700,51 +779,37 @@ ppSideBySideField subdocs unicode (ConDeclField names ltype _) = -- Where there is more than one name, they all have the same documentation mbDoc = lookup (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst --- {- --- ppHsFullConstr :: HsConDecl -> LaTeX --- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = --- declWithDoc False doc ( --- hsep ((ppHsConstrHdr tvs ctxt +++ --- ppHsBinder False nm) : map ppHsBangType typeList) --- ) --- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = --- td << vanillaTable << ( --- case doc of --- Nothing -> aboves [hdr, fields_html] --- Just _ -> aboves [hdr, constr_doc, fields_html] --- ) --- --- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) --- --- constr_doc --- | isJust doc = docBox (docToLaTeX (fromJust doc)) --- | otherwise = LaTeX.emptyTable --- --- fields_html = --- td << --- table ! [width "100%", cellpadding 0, cellspacing 8] << ( --- aboves (map ppFullField (concat (map expandField fields))) --- ) --- -} --- --- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX --- ppShortField summary unicode (ConDeclField (L _ name) ltype _) --- = tda [theclass "recfield"] << ( --- ppBinder summary (docNameOcc name) --- <+> dcolon unicode <+> ppLType unicode ltype --- ) --- --- {- --- ppFullField :: HsFieldDecl -> LaTeX --- ppFullField (HsFieldDecl [n] ty doc) --- = declWithDoc False doc ( --- ppHsBinder False n <+> dcolon <+> ppHsBangType ty --- ) --- ppFullField _ = error "ppFullField" --- --- expandField :: HsFieldDecl -> [HsFieldDecl] --- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] --- -} + +-- | Pretty-print a bundled pattern synonym +ppSideBySidePat :: [Located DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> Bool -- ^ unicode + -> LaTeX +ppSideBySidePat lnames typ (doc, argDocs) unicode = + decltt decl <-> rDoc mDoc <+> nl + $$ fieldPart + where + hasArgDocs = not $ Map.null argDocs + ppOcc = hsep (punctuate comma (map (ppDocBinder . unLoc) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppLType unicode (hsSigType typ) + ] + + fieldPart + | not hasArgDocs = empty + | otherwise = vcat + [ empty <-> text "\\qquad" <+> l <+> text "\\enspace" <+> r + | (l,r) <- ppSubSigLike unicode (unLoc patTy) argDocs [] (dcolon unicode) + ] + + patTy = hsSigType typ + + mDoc = fmap _doc $ combineDocumentation doc -- | Print the LHS of a data\/newtype declaration. @@ -760,6 +825,7 @@ ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars ppAppDocNameNames False name (tyvarNames tyvars) ppDataHeader _ _ = error "ppDataHeader: illegal argument" + -------------------------------------------------------------------------------- -- * Type applications -------------------------------------------------------------------------------- @@ -911,7 +977,7 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" -ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsRecTy {}) _ = text "{..}" ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys @@ -972,6 +1038,11 @@ ppBinder n | isInfixName n = parens $ ppOccName n | otherwise = ppOccName n +ppBinderInfix :: OccName -> LaTeX +ppBinderInfix n + | isInfixName n = ppOccName n + | otherwise = cat [ char '`', ppOccName n, char '`' ] + isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index bf71fec4..fcc52a99 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -40,10 +40,19 @@ import Name import BooleanFormula import RdrName ( rdrNameOcc ) -ppDecl :: Bool -> LinksInfo -> LHsDecl DocNameI - -> [(HsDecl DocNameI, DocForDecl DocName)] - -> DocForDecl DocName -> [DocInstance DocNameI] -> [(DocName, Fixity)] - -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html +-- | Pretty print a declaration +ppDecl :: Bool -- ^ print summary info only + -> LinksInfo -- ^ link information + -> LHsDecl DocNameI -- ^ declaration to print + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant pattern synonyms + -> DocForDecl DocName -- ^ documentation for this decl + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ documentation for all decls + -> Splice + -> Unicode -- ^ unicode output + -> Qualification + -> Html 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 pats splice unicode qual @@ -51,8 +60,8 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc 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 (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig lnames ty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames - ty fixities splice unicode qual + SigD (PatSynSig lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + (hsSigType lty) fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml DerivD _ -> noHtml @@ -75,20 +84,18 @@ ppFunSig summary links loc doc docnames typ fixities splice unicode qual = where pp_typ = ppLType unicode qual HideEmptyContexts typ -ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - [Located DocName] -> LHsSigType DocNameI -> - [(DocName, Fixity)] -> - Splice -> Unicode -> Qualification -> Html -ppLPatSig summary links loc (doc, _argDocs) docnames typ fixities splice unicode qual - | summary = pref1 - | otherwise = topDeclElem links loc splice (map unLoc docnames) (pref1 <+> ppFixities fixities qual) - +++ docSection Nothing qual doc +-- | Pretty print a pattern synonym +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> [Located DocName] -- ^ names of patterns in declaration + -> LHsType DocNameI -- ^ type of patterns in declaration + -> [(DocName, Fixity)] + -> Splice -> Unicode -> Qualification -> Html +ppLPatSig summary links loc doc lnames typ fixities splice unicode qual = + ppSigLike summary links loc (keyword "pattern") doc (map unLoc lnames) fixities + (unLoc typ, pp_typ) splice unicode qual (patSigContext typ) where - pref1 = hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppBinder summary . getOccName) docnames - , dcolon unicode - , ppPatSigType unicode qual (hsSigType typ) - ] + pp_typ = ppPatSigType unicode qual typ + ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocNameI, Html) -> @@ -97,7 +104,7 @@ ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) 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 + , (leader <+>) . addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames , dcolon unicode ) splice unicode qual emptyCtxts @@ -114,10 +121,26 @@ ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocNameI 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 +++ - subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc + | otherwise = topDeclElem links loc splice docnames pref2 + +++ subArguments qual (ppSubSigLike unicode qual typ argDocs [] sep emptyCtxts) + +++ docSection curName qual doc where curName = getName <$> listToMaybe docnames + + +-- This splits up a type signature along `->` and adds docs (when they exist) to +-- the arguments. +-- +-- If one passes in a list of the available subdocs, any top-level `HsRecTy` +-- found will be expanded out into their fields. +ppSubSigLike :: Unicode -> Qualification + -> HsType DocNameI -- ^ type signature + -> FnArgsDoc DocName -- ^ docs to add + -> [(DocName, DocForDecl DocName)] -- ^ all subdocs (useful when + -- we expand an `HsRecTy`) + -> Html -> HideEmptyContexts -> [SubDecl] +ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ + where argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t @@ -135,12 +158,32 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype + do_args n leader (HsFunTy (L _ (HsRecTy fields)) r) + = [ (ldr <+> html, mdoc, subs) + | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) + , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field + ] + ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r + do_args n leader (HsFunTy lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r + do_args n leader t = [(leader <+> ppType unicode qual emptyCtxts t, argDoc n, [])] + + -- FIXME: this should be done more elegantly + -- + -- We need 'gadtComma' and 'gadtEnd' to line up with the `{` from + -- 'gadtOpen', so we add 3 spaces to cover for `-> `/`:: ` (3 in unicode + -- mode since `->` and `::` are rendered as single characters. + gadtComma = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "," + gadtEnd = concatHtml (replicate (if unicode then 2 else 3) spaceHtml) <> toHtml "}" + gadtOpen = toHtml "{" + + + ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of @@ -707,11 +750,16 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual ] -ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocNameI] -> [(DocName, Fixity)] -> - [(DocName, DocForDecl DocName)] -> - SrcSpan -> Documentation DocName -> TyClDecl DocNameI -> - [(HsDecl DocNameI, DocForDecl DocName)] -> - Splice -> Unicode -> Qualification -> Html +-- | Pretty-print a data declaration +ppDataDecl :: Bool -> LinksInfo + -> [DocInstance DocNameI] -- ^ relevant instances + -> [(DocName, Fixity)] -- ^ relevant fixities + -> [(DocName, DocForDecl DocName)] -- ^ all decl documentation + -> SrcSpan + -> Documentation DocName -- ^ this decl's documentation + -> TyClDecl DocNameI -- ^ this decl + -> [(HsDecl DocNameI, DocForDecl DocName)] -- ^ relevant patterns + -> Splice -> Unicode -> Qualification -> Html ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats splice unicode qual @@ -740,25 +788,20 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) - (map unLoc (getConNames (unLoc c)))) fixities + (map unLoc (getConNames (unLoc c)))) fixities ] patternBit = subPatterns qual - [ (hsep [ keyword "pattern" - , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames - , dcolon unicode - , ppPatSigType 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 + [ ppSideBySidePat subfixs unicode qual lnames typ 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 - ppShortConstr :: Bool -> ConDecl DocNameI -> Unicode -> Qualification -> Html ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot where @@ -768,121 +811,180 @@ ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot -- returns three pieces: header, body, footer so that header & footer can be -- 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_args con of - PrefixCon args -> - (header_ unicode qual +++ hsep (ppOcc - : 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 HideEmptyContexts arg1, - ppOccInfix, ppLParendType unicode qual HideEmptyContexts arg2], - noHtml, noHtml) - - ConDeclGADT {} -> (ppOcc <+> dcolon unicode - <+> ppLType unicode qual HideEmptyContexts (getGADTConType con) - , noHtml, noHtml) - - where - doRecordFields fields = shortSubDecls dataInst $ - map (ppShortField summary unicode qual) (map unLoc fields) - - header_ = ppConstrHdr forall_ tyVars context - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder summary one - _ -> hsep (punctuate comma (map (ppBinder summary) occ)) +ppShortConstrParts summary dataInst con unicode qual + = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + + -- Prefix constructor, e.g. 'Just a' + PrefixCon args -> + ( header_ +++ hsep (ppOcc : map (ppLParendType unicode qual HideEmptyContexts) args) + , noHtml + , noHtml + ) - ppOccInfix = case occ of - [one] -> ppBinderInfix summary one - _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon (L _ fields) -> + ( header_ +++ ppOcc <+> char '{' + , shortSubDecls dataInst [ ppShortField summary unicode qual field + | L _ field <- fields + ] + , char '}' + ) - -- 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 + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 -> + ( header_ +++ hsep [ ppLParendType unicode qual HideEmptyContexts arg1 + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts arg2 + ] + , noHtml + , noHtml + ) + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT {} -> + ( hsep [ ppOcc, dcolon unicode, ppLType unicode qual HideEmptyContexts (getGADTConType con) ] + , noHtml + , noHtml + ) --- ppConstrHdr is for (non-GADT) existentials constructors' syntax -ppConstrHdr :: Bool -> [Name] -> HsContext DocNameI -> Unicode - -> Qualification -> Html -ppConstrHdr forall_ tvs ctxt unicode qual - = (if null tvs then noHtml else ppForall) - +++ - (if null ctxt then noHtml - else ppContextNoArrow ctxt unicode qual HideEmptyContexts - <+> darrow unicode +++ toHtml " ") where - ppForall | forall_ = forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) - <+> toHtml ". " - | otherwise = noHtml + occ = map (nameOccName . getName . unLoc) $ getConNames con + ppOcc = hsep (punctuate comma (map (ppBinder summary) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) + +-- | Pretty print an expanded constructor ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] - -> Unicode -> Qualification -> LConDecl DocNameI -> SubDecl + -> Unicode -> Qualification + -> LConDecl DocNameI -- ^ constructor declaration to print + -> SubDecl ppSideBySideConstr subdocs fixities unicode qual (L _ con) - = (decl, mbDoc, fieldPart) + = ( decl -- Constructor header (name, fixity) + , mbDoc -- Docs on the whole constructor + , fieldPart -- Information on the fields (or arguments, if they have docs) + ) where - decl = case con of - ConDeclH98{} -> case con_args con of - PrefixCon args -> - hsep ((header_ +++ ppOcc) - : map (ppLParendType unicode qual HideEmptyContexts) args) - <+> fixity + -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) + aConName = unLoc (head (getConNames con)) - RecCon _ -> header_ +++ ppOcc <+> fixity + fixity = ppFixities fixities qual + occ = map (nameOccName . getName . unLoc) $ getConNames con - InfixCon arg1 arg2 -> - hsep [header_ +++ ppLParendType unicode qual HideEmptyContexts arg1, - ppOccInfix, - ppLParendType unicode qual HideEmptyContexts arg2] - <+> fixity + ppOcc = hsep (punctuate comma (map (ppBinder False) occ)) + ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) + + -- Extract out the map of of docs corresponding to the constructors arguments + argDocs = maybe Map.empty snd (lookup aConName subdocs) + hasArgDocs = not $ Map.null argDocs + + decl = case con of + ConDeclH98{ con_args = det + , con_ex_tvs = vars + , con_mb_cxt = cxt + } -> let tyVars = map (getName . hsLTyVarName) vars + context = unLoc (fromMaybe (noLoc []) cxt) + forall_ = False + header_ = ppConstrHdr forall_ tyVars context unicode qual + in case det of + -- Prefix constructor, e.g. 'Just a' + PrefixCon args + | hasArgDocs -> header_ +++ ppOcc <+> fixity + | otherwise -> hsep [ header_ +++ ppOcc + , hsep (map (ppLParendType unicode qual HideEmptyContexts) args) + , fixity + ] + + -- Record constructor, e.g. 'Identity { runIdentity :: a }' + RecCon _ -> header_ +++ ppOcc <+> fixity - ConDeclGADT{} -> doGADTCon (getGADTConType con) + -- Infix constructor, e.g. 'a :| [a]' + InfixCon arg1 arg2 + | hasArgDocs -> header_ +++ ppOcc <+> fixity + | otherwise -> hsep [ header_ +++ ppLParendType unicode qual HideEmptyContexts arg1 + , ppOccInfix + , ppLParendType unicode qual HideEmptyContexts arg2 + , fixity + ] + + -- GADT constructor, e.g. 'Foo :: Int -> Foo' + ConDeclGADT{} + | hasArgDocs || not (null fieldPart) -> ppOcc <+> fixity + | otherwise -> hsep [ ppOcc + , dcolon unicode + -- ++AZ++ make this prepend "{..}" when it is a record style GADT + , ppLType unicode qual HideEmptyContexts (getGADTConType con) + , fixity + ] + + fieldPart = case (con, getConArgs con) of + -- Record style GADTs + (ConDeclGADT{}, RecCon _) -> [ doConstrArgsWithDocs [] ] + + -- Regular record declarations + (_, RecCon (L _ fields)) -> [ doRecordFields fields ] + + -- Any GADT or a regular H98 prefix data constructor + (_, PrefixCon args) | hasArgDocs -> [ doConstrArgsWithDocs args ] + + -- An infix H98 data constructor + (_, InfixCon arg1 arg2) | hasArgDocs -> [ doConstrArgsWithDocs [arg1,arg2] ] - fieldPart = case getConArgs con of - RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) - doGADTCon :: Located (HsType DocNameI) -> Html - doGADTCon ty = ppOcc <+> dcolon unicode - -- ++AZ++ make this prepend "{..}" when it is a record style GADT - <+> ppLType unicode qual HideEmptyContexts ty - <+> fixity + doConstrArgsWithDocs args = subFields qual $ case con of + ConDeclH98{} -> + [ (ppLParendType unicode qual HideEmptyContexts arg, mdoc, []) + | (i, arg) <- zip [0..] args + , let mdoc = Map.lookup i argDocs + ] + ConDeclGADT{} -> + ppSubSigLike unicode qual (unLoc (getGADTConType con)) + argDocs subdocs (dcolon unicode) HideEmptyContexts - fixity = ppFixities fixities qual - header_ = ppConstrHdr forall_ tyVars context unicode qual - occ = map (nameOccName . getName . unLoc) $ getConNames con - - ppOcc = case occ of - [one] -> ppBinder False one - _ -> hsep (punctuate comma (map (ppBinder False) occ)) - - ppOccInfix = case occ of - [one] -> ppBinderInfix False one - _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - - -- 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. mbDoc = lookup (unLoc $ head $ getConNames con) subdocs >>= combineDocumentation . fst +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: Bool -- ^ print explicit foralls + -> [Name] -- ^ type variables + -> HsContext DocNameI -- ^ context + -> Unicode -> Qualification -> Html +ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt + where + ppForall + | null tvs || not forall_ = noHtml + | otherwise = forallSymbol unicode + <+> hsep (map (ppName Prefix) tvs) + <+> toHtml ". " + + ppCtxt + | null ctxt = noHtml + | otherwise = ppContextNoArrow ctxt unicode qual HideEmptyContexts + <+> darrow unicode +++ toHtml " " + + +-- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocNameI -> SubDecl ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = - ( hsep (punctuate comma (map ((ppBinder False) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) + ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) + | L _ name <- names + , let field = (unLoc . rdrNameFieldOcc) name + ]) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype , mbDoc @@ -900,6 +1002,40 @@ ppShortField summary unicode qual (ConDeclField names ltype _) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype +-- | Pretty print an expanded pattern (for bundled patterns) +ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification + -> [Located DocName] -- ^ pattern name(s) + -> LHsSigType DocNameI -- ^ type of pattern(s) + -> DocForDecl DocName -- ^ doc map + -> SubDecl +ppSideBySidePat fixities unicode qual lnames typ (doc, argDocs) = + ( decl + , combineDocumentation doc + , fieldPart + ) + where + hasArgDocs = not $ Map.null argDocs + fixity = ppFixities fixities qual + ppOcc = hsep (punctuate comma (map (ppBinder False . getOccName) lnames)) + + decl | hasArgDocs = keyword "pattern" <+> ppOcc <+> fixity + | otherwise = hsep [ keyword "pattern" + , ppOcc + , dcolon unicode + , ppPatSigType unicode qual (hsSigType typ) + , fixity + ] + + fieldPart + | not hasArgDocs = [] + | otherwise = [ subFields qual (ppSubSigLike unicode qual (unLoc patTy) + argDocs [] (dcolon unicode) + emptyCtxt) ] + + patTy = hsSigType typ + emptyCtxt = patSigContext patTy + + -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocNameI -> Unicode -> Qualification -> Html @@ -990,13 +1126,9 @@ ppLKind unicode qual y = ppKind unicode qual (unLoc y) ppKind :: Unicode -> Qualification -> HsKind DocNameI -> Html ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual HideEmptyContexts -ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html -ppPatSigType unicode qual typ = - let emptyCtxts = - if hasNonEmptyContext typ && isFirstContextEmpty typ - then ShowEmptyToplevelContexts - else HideEmptyContexts - in ppLType unicode qual emptyCtxts typ +patSigContext :: LHsType name -> HideEmptyContexts +patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmptyToplevelContexts + | otherwise = HideEmptyContexts where hasNonEmptyContext :: LHsType name -> Bool hasNonEmptyContext t = @@ -1013,6 +1145,13 @@ ppPatSigType unicode qual typ = HsFunTy _ s -> isFirstContextEmpty s _ -> False + +-- | Pretty-print a pattern signature (all this does over 'ppLType' is slot in +-- the right 'HideEmptyContext' value) +ppPatSigType :: Unicode -> Qualification -> LHsType DocNameI -> Html +ppPatSigType unicode qual typ = + let emptyCtxts = patSigContext typ in ppLType unicode qual emptyCtxts typ + ppForAllPart :: Unicode -> Qualification -> [LHsTyVarBndr DocNameI] -> Html ppForAllPart unicode qual tvs = hsep (forallSymbol unicode : ppTyVars unicode qual tvs) +++ dot diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index a75c4b9a..7fbaec6d 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -110,7 +110,7 @@ renderToString debug html hsep :: [Html] -> Html hsep [] = noHtml -hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls +hsep htmls = foldr1 (<+>) htmls -- | Concatenate a series of 'Html' values vertically, with linebreaks in between. vcat :: [Html] -> Html @@ -232,4 +232,4 @@ collapseToggle id_ classes = [ theclass cs, strAttr "data-details-id" id_ ] -- and displays a control. collapseControl :: String -> String -> [HtmlAttr] collapseControl id_ classes = collapseToggle id_ cs - where cs = unwords (words classes ++ ["details-toggle-control"]) \ No newline at end of file + where cs = unwords (words classes ++ ["details-toggle-control"]) diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 52a983a8..f673e23b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -380,7 +380,7 @@ mkMaps dflags gre instances decls = do m' <- traverse (processDocStringParas dflags gre) m pure (doc', m') - (doc, args) <- declDoc docStrs (typeDocs decl) + (doc, args) <- declDoc docStrs (declTypeDocs decl) let subs :: [(Name, [HsDocString], Map Int HsDocString)] @@ -445,14 +445,14 @@ subordinates instMap decl = case decl of | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where - classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd + classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) - constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty) + constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c) | c <- cons, cname <- getConNames c ] fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConArgs cons @@ -464,17 +464,33 @@ subordinates instMap decl = case decl of unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] +-- | Extract constructor argument docs from inside constructor decls. +conArgDocs :: ConDecl GhcRn -> Map Int HsDocString +conArgDocs con = case getConArgs con of + PrefixCon args -> go 0 (map unLoc args ++ ret) + InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) + RecCon _ -> go 1 ret + where + go n (HsDocTy _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys + go n (_ : tys) = go (n+1) tys + go _ [] = M.empty + + ret = case con of + ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] + _ -> [] + +-- | Extract function argument docs from inside top-level decls. +declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString +declTypeDocs (SigD (TypeSig _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD (ClassOpSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD (PatSynSig _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) +declTypeDocs _ = M.empty + -- | Extract function argument docs from inside types. -typeDocs :: HsDecl GhcRn -> Map Int HsDocString -typeDocs d = - let docs = go 0 in - case d of - SigD (TypeSig _ ty) -> docs (unLoc (hsSigWcType ty)) - SigD (ClassOpSig _ _ ty) -> docs (unLoc (hsSigType ty)) - SigD (PatSynSig _ ty) -> docs (unLoc (hsSigType ty)) - ForD (ForeignImport _ ty _ _) -> docs (unLoc (hsSigType ty)) - TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) - _ -> M.empty +typeDocs :: HsType GhcRn -> Map Int HsDocString +typeDocs = go 0 where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) @@ -483,7 +499,6 @@ typeDocs d = go n (HsDocTy _ (L _ doc)) = M.singleton n doc go _ _ = M.empty - -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -- cgit v1.2.3 From b6a719bb3dcc51da8c162e213a4fdc43a35cb992 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 15 Jan 2018 17:12:18 -0800 Subject: Update the GblRdrEnv when processing modules Without a complete environment, we will miss some instances that were encountered during typechecking. --- haddock-api/src/Haddock/Interface.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index 20689a8f..cbdf81cb 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -58,6 +58,8 @@ import GHC hiding (verbosity) import HscTypes import FastString (unpackFS) import MonadUtils (liftIO) +import TcRnTypes (tcg_rdr_env) +import RdrName (plusGlobalRdrEnv) #if defined(mingw32_HOST_OS) import System.IO @@ -163,6 +165,18 @@ processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap - processModule verbosity modsum flags modMap instIfaceMap = do out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tm <- loadModule =<< typecheckModule =<< parseModule modsum + + -- We need to modify the interactive context's environment so that when + -- Haddock later looks for instances, it also looks in the modules it + -- encountered while typechecking. + -- + -- See https://github.com/haskell/haddock/issues/469. + hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession + let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm + setSession hsc_env{ hsc_IC = old_IC { + ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env + } } + if not $ isBootSummary modsum then do out verbosity verbose "Creating interface..." (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap -- cgit v1.2.3 From 48ee5587b574105a231072999b06aa56c37292c4 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 19 Jan 2018 04:44:02 -0500 Subject: Fix #732 (#733) --- haddock-api/src/Haddock/GhcUtils.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 4963d2f8..17c92688 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -169,8 +169,8 @@ getGADTConType (ConDeclGADT { con_forall = has_forall tau_ty = case args of RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr (\ a b -> noLoc (HsFunTy a b)) res_ty pos_args - InfixCon {} -> panic "InfixCon for GADT" + PrefixCon pos_args -> foldr nlHsFunTy res_ty pos_args + InfixCon arg1 arg2 -> arg1 `nlHsFunTy` (arg2 `nlHsFunTy` res_ty) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT -- cgit v1.2.3 From 107ef5a33b0d33063b4b709582ca081916b46098 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Fri, 19 Jan 2018 15:33:30 +0100 Subject: extractDecl: Extract associated types correctly (#736) --- haddock-api/src/Haddock/Interface/Create.hs | 32 +++++++++++++++++++---------- 1 file changed, 21 insertions(+), 11 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index f673e23b..bd990170 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1014,21 +1014,31 @@ extractDecl name decl | otherwise = case unLoc decl of TyClD d@ClassDecl {} -> - let matches = [ lsig - | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig - -- Note: exclude `default` declarations (see #505) - , name `elem` sigName lsig - ] + let + matchesMethod = + [ lsig + | lsig <- tcdSigs d + , ClassOpSig False _ _ <- pure $ unLoc lsig + -- Note: exclude `default` declarations (see #505) + , name `elem` sigName lsig + ] + + matchesAssociatedType = + [ lfam_decl + | lfam_decl <- tcdATs d + , name == unLoc (fdLName (unLoc lfam_decl)) + ] + -- TODO: document fixity - in case matches of - [s0] -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) - L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) + in case (matchesMethod, matchesAssociatedType) of + ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) + L pos sig = addClassContext n tyvar_names s0 + in L pos (SigD sig) + (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" - O.$$ O.nest 4 (O.ppr matches)) + O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) TyClD d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars d)) in if isDataConName name -- cgit v1.2.3 From 3291502a4a15f30eaafdb22da4292a17e08aa7bd Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Sat, 20 Jan 2018 19:18:20 +0100 Subject: Fix duplicate declarations and TypeFamilies specifics --- haddock-api/src/Haddock/Interface/Create.hs | 46 ++++++++++++++++++----------- 1 file changed, 29 insertions(+), 17 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index bd990170..4866f76b 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -115,7 +115,7 @@ createInterface tm flags modMap instIfaceMap = do unrestrictedImportedMods -- module re-exports are only possible with -- explicit export list - | Just _ <- exports + | Just{} <- exports = unrestrictedModuleImports (map unLoc imports) | otherwise = M.empty @@ -704,11 +704,6 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let declNames = getMainDeclBinder (unL decl) in case () of _ - -- TODO: temp hack: we filter out separately exported ATs, since we haven't decided how - -- to handle them yet. We should really give an warning message also, and filter the - -- name out in mkVisibleNames... - | t `elem` declATs (unL decl) -> return [] - -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. | t `notElem` declNames, @@ -782,7 +777,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames return [ ExportDecl { expItemDecl = restrictTo (fmap fst subs) - (extractDecl (availName avail) decl) + (extractDecl declMap (availName avail) decl) , expItemPats = bundledPatSyns , expItemMbDoc = doc , expItemSubDocs = subs @@ -794,7 +789,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames | otherwise = return [ ExportDecl { - expItemDecl = extractDecl sub decl + expItemDecl = extractDecl declMap sub decl , expItemPats = [] , expItemMbDoc = sub_doc , expItemSubDocs = [] @@ -993,23 +988,32 @@ fullModuleContents :: Bool -- is it a signature -> Avails -> ErrMsgGhc [ExportItem GhcRn] fullModuleContents is_sig modMap thisMod semMod warnings exportedNames - decls maps fixMap splices instIfaceMap dflags avails = do - let availEnv = availsToNameEnv avails + decls maps@(_, _, declMap, _) fixMap splices instIfaceMap dflags avails = do + let availEnv = availsToNameEnv (nubAvails avails) (concat . concat) `fmap` (for decls $ \decl -> do for (getMainDeclBinder (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of - Just avail -> availExportItem is_sig modMap thisMod - semMod warnings exportedNames maps fixMap - splices instIfaceMap dflags avail + Just avail + | L _ (ValD valDecl) <- decl + , (name:_) <- collectHsBindBinders valDecl + , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap + -> pure [] + + | otherwise + -> availExportItem is_sig modMap thisMod + semMod warnings exportedNames maps fixMap + splices instIfaceMap dflags avail Nothing -> pure []) - + where + isSigD (L _ SigD{}) = True + isSigD _ = False -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: Name -> LHsDecl GhcRn -> LHsDecl GhcRn -extractDecl name decl +extractDecl :: DeclMap -> Name -> LHsDecl GhcRn -> LHsDecl GhcRn +extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of @@ -1035,6 +1039,10 @@ extractDecl name decl L pos sig = addClassContext n tyvar_names s0 in L pos (SigD sig) (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + + ([], []) + | Just (famInstDecl:_) <- M.lookup name declMap + -> extractDecl declMap name famInstDecl _ -> O.pprPanic "extractDecl" (O.text "Ambiguous decl for" O.<+> O.ppr name O.<+> O.text "in class:" O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" @@ -1044,6 +1052,10 @@ extractDecl name decl 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)) + TyClD FamDecl {} + | isValName name + , Just (famInst:_) <- M.lookup name declMap + -> extractDecl declMap name famInst InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_pats = tys @@ -1059,7 +1071,7 @@ extractDecl name decl , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -- cgit v1.2.3 From 0ef6a26d49fc2b3a5785a55d95b64f77c40e58ad Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Sat, 3 Feb 2018 11:47:10 +0100 Subject: QuickJump: Mitigate encoding problems on Windows (cherry picked from commit 86292c54bfee2343aee84559ec01f1fc68f52231) --- haddock-api/src/Haddock/Backends/Xhtml.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 55175163..2d23ddc7 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -36,11 +36,13 @@ import Text.XHtml hiding ( name, title, p, quote ) import Haddock.GhcUtils import Control.Monad ( when, unless ) +import qualified Data.ByteString.Builder as Builder import Data.Char ( toUpper, isSpace ) import Data.List ( sortBy, isPrefixOf, intercalate, intersperse ) import Data.Maybe -import System.FilePath hiding ( () ) import System.Directory +import System.FilePath hiding ( () ) +import qualified System.IO as IO import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import qualified Data.Set as Set hiding ( Set ) @@ -353,9 +355,8 @@ ppJsonIndex :: FilePath -> IO () ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do createDirectoryIfMissing True odir - writeFile (joinPath [odir, indexJsonFile]) - (encodeToString modules) - + IO.withFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do + Builder.hPutBuilder h (encodeToBuilder modules) where modules :: Value modules = Array (concatMap goInterface ifaces) -- cgit v1.2.3 From 06fc4934e96bd2e647496ec0082d6ef362328f64 Mon Sep 17 00:00:00 2001 From: alexbiehl Date: Sun, 4 Feb 2018 18:38:33 +0100 Subject: Use withBinaryFile --- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 2d23ddc7..00937245 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -355,7 +355,7 @@ ppJsonIndex :: FilePath -> IO () ppJsonIndex odir maybe_source_url maybe_wiki_url unicode qual_opt ifaces = do createDirectoryIfMissing True odir - IO.withFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do + IO.withBinaryFile (joinPath [odir, indexJsonFile]) IO.WriteMode $ \h -> do Builder.hPutBuilder h (encodeToBuilder modules) where modules :: Value -- cgit v1.2.3 From 4804e39144dc0ded9b38dbb3442b6016ac719a1a Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Mon, 19 Feb 2018 04:34:49 +0000 Subject: Haddock: support splitted include paths. (#689) --- haddock-api/src/Haddock/GhcUtils.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 17c92688..b3260fd5 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -28,6 +28,7 @@ import Module import HscTypes import GHC import Class +import DynFlags moduleString :: Module -> String @@ -282,7 +283,8 @@ minimalDef n = do setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags setObjectDir f d = d{ objectDir = Just f} setHiDir f d = d{ hiDir = Just f} -setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } +setStubDir f d = d{ stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f -- cgit v1.2.3 From 067d52fd4be15a1842cbb05f42d9d482de0ad3a7 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Tue, 6 Mar 2018 13:43:56 -0500 Subject: Updates for #13324 --- haddock-api/src/Haddock/Interface/Rename.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index fadd0553..6a0a20cf 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -526,7 +526,7 @@ renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do - ty' <- renameLSigType ty + ty' <- renameLSigWcType ty return (DerivDecl { deriv_type = ty' , deriv_strategy = strat , deriv_overlap_mode = omode }) -- cgit v1.2.3 From d0de7f1219172a6b52e7a02a716aed8c1dc8aaa2 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 7 Apr 2018 14:14:32 +0200 Subject: Match changes in GHC for D4199 Removing HasSourceText and SourceTextX classes. --- haddock-api/src/Haddock/Backends/Hoogle.hs | 3 ++- haddock-api/src/Haddock/Types.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index ee81a83c..2feb0fb9 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Hoogle @@ -87,7 +88,7 @@ dropHsDocTy = f f (HsDocTy a _) = f $ unL a f x = x -outHsType :: (SourceTextX a, OutputableBndrId a) +outHsType :: (a ~ GhcPass p, OutputableBndrId a) => DynFlags -> HsType a -> String outHsType dflags = out dflags . dropHsDocTy diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b4cdc343..af8904d3 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -347,7 +347,7 @@ data InstType name | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) | DataInst (TyClDecl name) -- ^ Data constructors -instance (SourceTextX a, OutputableBndrId a) +instance (a ~ GhcPass p,OutputableBndrId a) => Outputable (InstType a) where ppr (ClassInst { .. }) = text "ClassInst" <+> ppr clsiCtx -- cgit v1.2.3 From c84939c8428a9e9ae0753e75ca6b48fcbbc1ecd6 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 8 Apr 2018 16:21:27 +0200 Subject: Match GHC changes for TTG --- haddock-api/src/Haddock/Backends/Hoogle.hs | 38 ++--- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 16 +- haddock-api/src/Haddock/Backends/LaTeX.hs | 52 +++---- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 71 ++++----- haddock-api/src/Haddock/Convert.hs | 54 ++++--- haddock-api/src/Haddock/GhcUtils.hs | 54 ++++++- haddock-api/src/Haddock/Interface/Create.hs | 34 ++--- haddock-api/src/Haddock/Interface/Rename.hs | 72 ++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 162 ++++++++++----------- haddock-api/src/Haddock/Types.hs | 44 +++++- haddock-api/src/Haddock/Utils.hs | 15 +- 11 files changed, 343 insertions(+), 269 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 2feb0fb9..9e0b5102 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -74,18 +74,18 @@ dropHsDocTy :: HsType a -> HsType a dropHsDocTy = f where g (L src x) = L src (f x) - f (HsForAllTy a e) = HsForAllTy a (g e) - f (HsQualTy a e) = HsQualTy a (g e) - f (HsBangTy a b) = HsBangTy a (g b) - f (HsAppTy a b) = HsAppTy (g a) (g b) - f (HsFunTy a b) = HsFunTy (g a) (g b) - f (HsListTy a) = HsListTy (g a) - f (HsPArrTy a) = HsPArrTy (g a) - f (HsTupleTy a b) = HsTupleTy a (map g b) - f (HsOpTy a b c) = HsOpTy (g a) b (g c) - f (HsParTy a) = HsParTy (g a) - f (HsKindSig a b) = HsKindSig (g a) b - f (HsDocTy a _) = f $ unL a + f (HsForAllTy x a e) = HsForAllTy x a (g e) + f (HsQualTy x a e) = HsQualTy x a (g e) + f (HsBangTy x a b) = HsBangTy x a (g b) + f (HsAppTy x a b) = HsAppTy x (g a) (g b) + f (HsFunTy x a b) = HsFunTy x (g a) (g b) + f (HsListTy x a) = HsListTy x (g a) + f (HsPArrTy x a) = HsPArrTy x (g a) + f (HsTupleTy x a b) = HsTupleTy x a (map g b) + f (HsOpTy x a b c) = HsOpTy x (g a) b (g c) + f (HsParTy x a) = HsParTy x (g a) + f (HsKindSig x a b) = HsKindSig x (g a) b + f (HsDocTy _ a _) = f $ unL a f x = x outHsType :: (a ~ GhcPass p, OutputableBndrId a) @@ -237,12 +237,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} 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 . noLoc . selectorFieldOcc . unLoc) (cd_fld_names r)) ++ - [out dflags (map (selectorFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] + [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ + [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy x y) - apps = foldl1 (\x y -> reL $ HsAppTy x y) + funs = foldr1 (\x y -> reL $ HsFunTy PlaceHolder x y) + apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -250,13 +250,13 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar NotPromoted . reL) $ - (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvExplicit $ tyClDeclTyVars dat] + resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $ + (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@(ConDeclGADT { }) = concatMap (lookupCon dflags subdocs) (getConNames con) ++ f where - f = [typeSig name (getGADTConType con)] + f = [typeSig name (getGADTConTypeG con)] typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 57ff72ff..3d7575eb 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -84,9 +84,9 @@ variables = everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) -> pure (sspan, RtkVar (GHC.unLoc name)) - (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> + (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of @@ -99,7 +99,7 @@ types :: GHC.RenamedSource -> LTokenDetails types = everythingInRenamedSource ty where ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty @@ -118,11 +118,11 @@ binds = everythingInRenamedSource pure (sspan, RtkBind name) _ -> empty pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs - (Just (GHC.L _ (GHC.AsPat (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty rec term = case cast term of @@ -130,9 +130,9 @@ binds = everythingInRenamedSource pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> + (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> + (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -167,7 +167,7 @@ decls (group, _, _, _) = concatMap ($ group) _ -> empty fld term = case cast term of Just (field :: GHC.ConDeclField GHC.GhcRn) - -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field + -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field Nothing -> empty sig (GHC.L _ (GHC.TypeSig names _)) = map decl names sig _ = [] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 51e183c7..1229a8d3 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -412,22 +412,22 @@ ppSubSigLike unicode typ argDocs subdocs leader = do_args 0 leader typ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> HsType DocNameI -> [(LaTeX, LaTeX)] - do_args _n leader (HsForAllTy tvs ltype) + do_args _n leader (HsForAllTy _ tvs ltype) = [ ( decltt leader , decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot])) <+> ppLType unicode ltype ) ] - do_args n leader (HsQualTy lctxt ltype) + do_args n leader (HsQualTy _ lctxt ltype) = (decltt leader, ppLContextNoArrow lctxt unicode <+> nl) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy (L _ (HsRecTy fields)) r) + do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) = [ (decltt ldr, latex <+> nl) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let latex = ppSideBySideField subdocs unicode field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy lt r) + do_args n leader (HsFunTy _ lt r) = (decltt leader, decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl) : do_largs (n+1) (arrow unicode) r do_args n leader t @@ -777,7 +777,7 @@ ppSideBySideField subdocs unicode (ConDeclField names ltype _) = 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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst + mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- | Pretty-print a bundled pattern synonym @@ -957,57 +957,57 @@ ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocNameI -> Bool -> LaTeX -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode +ppr_mono_ty ctxt_prec (HsForAllTy _ tvs ty) unicode = maybeParen ctxt_prec pREC_FUN $ sep [ hsep (forallSymbol unicode : ppTyVars tvs) <> dot , ppr_mono_lty pREC_TOP ty unicode ] -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode +ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $ sep [ ppLContext ctxt unicode , ppr_mono_lty pREC_TOP ty unicode ] -ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar NotPromoted (L _ name)) _ = ppDocName name -ppr_mono_ty _ (HsTyVar Promoted (L _ name)) _ = char '\'' <> ppDocName name -ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u -ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) -ppr_mono_ty _ (HsSumTy tys) u = sumParens (map (ppLType u) tys) -ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) -ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsIParamTy (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsBangTy _ b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty _ (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name +ppr_mono_ty _ (HsTyVar _ Promoted (L _ name)) _ = char '\'' <> ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy _ ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u +ppr_mono_ty _ (HsTupleTy _ con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty _ (HsSumTy _ tys) u = sumParens (map (ppLType u) tys) +ppr_mono_ty _ (HsKindSig _ ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty _ (HsListTy _ ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy _ ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsIParamTy _ (L _ n) ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsRecTy {}) _ = text "{..}" -ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" -ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy _ Promoted tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitListTy _ NotPromoted tys) u = brackets $ hsep $ punctuate comma $ map (ppLType u) tys ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys -ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode +ppr_mono_ty ctxt_prec (HsEqTy _ ty1 ty2) unicode = maybeParen ctxt_prec pREC_OP $ ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode +ppr_mono_ty ctxt_prec (HsAppTy _ fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode +ppr_mono_ty ctxt_prec (HsOpTy _ ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op occName = nameOccName . getName . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy ty) unicode +ppr_mono_ty ctxt_prec (HsParTy _ ty) unicode -- = parens (ppr_mono_lty pREC_TOP ty) = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode +ppr_mono_ty ctxt_prec (HsDocTy _ ty _) unicode = ppr_mono_lty ctxt_prec ty unicode ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u +ppr_mono_ty _ (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty _ (HsAppsTy {}) _ = panic "ppr_mono_ty:HsAppsTy" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index fcc52a99..a4f2a4a5 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -146,26 +146,26 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ do_largs n leader (L _ t) = do_args n leader t do_args :: Int -> Html -> HsType DocNameI -> [SubDecl] - do_args n leader (HsForAllTy tvs ltype) + do_args n leader (HsForAllTy _ tvs ltype) = do_largs n leader' ltype where leader' = leader <+> ppForAll tvs unicode qual - do_args n leader (HsQualTy lctxt ltype) + do_args n leader (HsQualTy _ lctxt ltype) | null (unLoc lctxt) = do_largs n leader ltype | otherwise = (leader <+> ppLContextNoArrow lctxt unicode qual emptyCtxts, Nothing, []) : do_largs n (darrow unicode) ltype - do_args n leader (HsFunTy (L _ (HsRecTy fields)) r) + do_args n leader (HsFunTy _ (L _ (HsRecTy _ fields)) r) = [ (ldr <+> html, mdoc, subs) | (L _ field, ldr) <- zip fields (leader <+> gadtOpen : repeat gadtComma) , let (html, mdoc, subs) = ppSideBySideField subdocs unicode qual field ] ++ do_largs (n+1) (gadtEnd <+> arrow unicode) r - do_args n leader (HsFunTy lt r) + do_args n leader (HsFunTy _ lt r) = (leader <+> ppLFunLhType unicode qual emptyCtxts lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r @@ -186,7 +186,7 @@ ppSubSigLike unicode qual typ argDocs subdocs sep emptyCtxts = do_args 0 sep typ ppForAll :: [LHsTyVarBndr DocNameI] -> Unicode -> Qualification -> Html ppForAll tvs unicode qual = - case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- tvs] of + case [ppKTv n k | L _ (KindedTyVar _ (L _ n) k) <- tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $ @@ -993,7 +993,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = 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 (selectorFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst + mbDoc = lookup (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html @@ -1114,11 +1114,12 @@ ppParendType unicode qual emptyCtxts ty = ppr_mono_ty pREC_CON ty unicode qual e ppFunLhType unicode qual emptyCtxts ty = ppr_mono_ty pREC_FUN ty unicode qual emptyCtxts ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocNameI -> Html -ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = +ppHsTyVarBndr _ qual (UserTyVar _ (L _ name)) = ppDocName qual Raw False name -ppHsTyVarBndr unicode qual (KindedTyVar name kind) = +ppHsTyVarBndr unicode qual (KindedTyVar _ name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> ppLKind unicode qual kind) +ppHsTyVarBndr _ _ (XTyVarBndr _) = error "haddock:ppHsTyVarBndr" ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html ppLKind unicode qual y = ppKind unicode qual (unLoc y) @@ -1133,16 +1134,16 @@ patSigContext typ | hasNonEmptyContext typ && isFirstContextEmpty typ = ShowEmp 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 + 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 + HsForAllTy _ _ s -> isFirstContextEmpty s + HsQualTy _ cxt _ -> null (unLoc cxt) + HsFunTy _ _ s -> isFirstContextEmpty s _ -> False @@ -1160,50 +1161,50 @@ ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocNameI -> Unicode -> Qualification -> HideEmptyContexts -> Html -ppr_mono_ty ctxt_prec (HsForAllTy tvs ty) unicode qual emptyCtxts +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 emptyCtxts -ppr_mono_ty ctxt_prec (HsQualTy ctxt ty) unicode qual emptyCtxts +ppr_mono_ty ctxt_prec (HsQualTy _ ctxt ty) unicode qual emptyCtxts = maybeParen ctxt_prec pREC_FUN $ 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 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 = +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 _ = +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 HideEmptyContexts) tys -ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) u q _ = brackets $ hsep $ punctuate comma $ map (ppLType u q HideEmptyContexts) tys +ppr_mono_ty _ (XHsType (NHsCoreTy {})) _ _ _ = 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 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 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 HideEmptyContexts <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual HideEmptyContexts where @@ -1214,15 +1215,15 @@ 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 emptyCtxts +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 emptyCtxts -ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual emptyCtxts +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 _ (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 37fad036..fac448a2 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -151,7 +151,7 @@ synifyTyCon _coax tc DataDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: let mk_hs_tv realKind fakeTyVar - = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) + = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) in HsQTvs { hsq_implicit = [] -- No kind polymorphism , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) @@ -266,7 +266,7 @@ synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = noLoc $ KindSig (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig (noLoc $ KindedTyVar (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -292,12 +292,12 @@ synifyDataCon use_gadt_syntax dc = let tySyn = synifyType WithinType ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn - bang' -> noLoc $ HsBangTy bang' tySyn) + bang' -> noLoc $ HsBangTy noExt bang' tySyn) arg_tys (dataConSrcBangs dc) field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLoc $ - ConDeclField [noLoc $ FieldOcc (noLoc $ mkVarUnqual $ flLabel fl) (flSelector fl)] synTy + ConDeclField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" @@ -347,8 +347,8 @@ synifyTyVars ktvs = HsQTvs { hsq_implicit = [] synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) - | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) + | isLiftedTypeKind kind = noLoc (UserTyVar noExt (noLoc name)) + | otherwise = noLoc (KindedTyVar noExt (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv @@ -365,7 +365,7 @@ annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty hs_ki = synifyType WithinType ki - in noLoc (HsKindSig hs_ty hs_ki) + in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty -- | For every type variable in the input, @@ -410,7 +410,7 @@ synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) synifyType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) = maybe_sig res_ty where @@ -420,41 +420,43 @@ synifyType _ (TyConApp tc tys) | tc `hasKey` tYPETyConKey , [TyConApp lev []] <- tys , lev `hasKey` liftedRepDataConKey - = noLoc (HsTyVar NotPromoted (noLoc starKindTyConName)) + = noLoc (HsTyVar noExt NotPromoted (noLoc starKindTyConName)) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys - = noLoc $ HsTupleTy (case sort of + = noLoc $ HsTupleTy noExt + (case sort of BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = - noLoc $ HsListTy (synifyType WithinType ty) + noLoc $ HsListTy noExt (synifyType WithinType ty) -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy (noLoc $ HsIPName x) (synifyType WithinType ty) + = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys - = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) + = noLoc $ HsEqTy noExt (synifyType WithinType ty1) (synifyType WithinType ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys - = mk_app_tys (HsOpTy (synifyType WithinType ty1) + = mk_app_tys (HsOpTy noExt + (synifyType WithinType ty1) (noLoc $ getName tc) (synifyType WithinType ty2)) tys_rest -- Most TyCons: | otherwise - = mk_app_tys (HsTyVar NotPromoted $ noLoc (getName tc)) + = mk_app_tys (HsTyVar noExt NotPromoted $ noLoc (getName tc)) vis_tys where mk_app_tys ty_app ty_args = - foldl (\t1 t2 -> noLoc $ HsAppTy t1 t2) + foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2) (noLoc ty_app) (map (synifyType WithinType) $ filterOut isCoercionTy ty_args) @@ -468,7 +470,7 @@ synifyType _ (TyConApp tc tys) | needs_kind_sig = let full_kind = typeKind (mkTyConApp tc tys) full_kind' = synifyType WithinType full_kind - in noLoc $ HsKindSig ty' full_kind' + in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' needs_kind_sig :: Bool @@ -489,22 +491,24 @@ synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 - in noLoc $ HsAppTy s1 s2 + in noLoc $ HsAppTy noExt s1 s2 synifyType _ (FunTy t1 t2) = let s1 = synifyType WithinType t1 s2 = synifyType WithinType t2 - in noLoc $ HsFunTy s1 s2 + in noLoc $ HsFunTy noExt s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExt , hst_body = synifyType WithinType tau } in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau WithinType -> noLoc $ HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_xforall = noExt , hst_body = noLoc sPhi } ImplicitizeForAll -> noLoc sPhi -synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t +synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" @@ -517,10 +521,12 @@ synifyPatSynType ps = let -- possible by taking theta = [], as that will print no context at all | otherwise = req_theta sForAll [] s = s - sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_body = noLoc s } + sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs + , hst_xforall = noExt + , hst_body = noLoc s } + sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta + , hst_xqual = noExt + , hst_body = noLoc s } sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index b3260fd5..48a9f99e 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -150,7 +151,12 @@ nubByName f ns = go emptyNameSet ns where y = f x -getGADTConType :: ConDecl p -> LHsType p +-- --------------------------------------------------------------------- + +-- This function is duplicated as getGADTConType and getGADTConTypeG, +-- as I can't get the types to line up otherwise. AZ. + +getGADTConType :: ConDecl DocNameI -> LHsType DocNameI -- The full type of a GADT data constructor We really only get this in -- order to pretty-print it, and currently only in Haddock's code. So -- we are cavalier about locations and extensions, hence the @@ -159,23 +165,57 @@ getGADTConType (ConDeclGADT { con_forall = has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_bndrs = hsQTvExplicit qtvs + | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty tau_ty = case args of - RecCon flds -> noLoc (HsFunTy (noLoc (HsRecTy (unLoc flds))) res_ty) - PrefixCon pos_args -> foldr nlHsFunTy res_ty pos_args - InfixCon arg1 arg2 -> arg1 `nlHsFunTy` (arg2 `nlHsFunTy` res_ty) + RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty) + PrefixCon pos_args -> foldr mkFunTy res_ty pos_args + InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + + mkFunTy a b = noLoc (HsFunTy noExt a b) getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT +-- ------------------------------------- + +getGADTConTypeG :: ConDecl (GhcPass p) -> LHsType (GhcPass p) +-- The full type of a GADT data constructor We really only get this in +-- order to pretty-print it, and currently only in Haddock's code. So +-- we are cavalier about locations and extensions, hence the +-- 'undefined's +getGADTConTypeG (ConDeclGADT { con_forall = has_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty }) + | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + , hst_bndrs = hsQTvExplicit qtvs + , hst_body = theta_ty }) + | otherwise = theta_ty + where + theta_ty | Just theta <- mcxt + = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) + | otherwise + = tau_ty + + tau_ty = case args of + RecCon flds -> noLoc (HsFunTy noExt (noLoc (HsRecTy noExt (unLoc flds))) res_ty) + PrefixCon pos_args -> foldr mkFunTy res_ty pos_args + InfixCon arg1 arg2 -> arg1 `mkFunTy` (arg2 `mkFunTy` res_ty) + + mkFunTy a b = noLoc (HsFunTy noExt a b) + +getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConType" + -- Should only be called on ConDeclGADT + ------------------------------------------------------------------------------- -- * Located ------------------------------------------------------------------------------- @@ -208,7 +248,7 @@ class Parent a where instance Parent (ConDecl GhcRn) where children con = case con_args con of - RecCon fields -> map (selectorFieldOcc . unL) $ + RecCon fields -> map (extFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4866f76b..88b8bc67 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -454,12 +454,12 @@ subordinates instMap decl = case decl of cons = map unL $ (dd_cons dd) constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c) | c <- cons, cname <- getConNames c ] - fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty) + fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConArgs cons , L _ (ConDeclField ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) - | HsIB { hsib_body = L l (HsDocTy _ doc) } + | HsIB { hsib_body = L l (HsDocTy _ _ doc) } <- concatMap (unLoc . deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd , Just instName <- [M.lookup l instMap] ] @@ -471,7 +471,7 @@ conArgDocs con = case getConArgs con of InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret) RecCon _ -> go 1 ret where - go n (HsDocTy _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys + go n (HsDocTy _ _ (L _ ds) : tys) = M.insert n ds $ go (n+1) tys go n (_ : tys) = go (n+1) tys go _ [] = M.empty @@ -494,9 +494,9 @@ typeDocs = go 0 where go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty) go n (HsQualTy { hst_body = ty }) = go n (unLoc ty) - go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty - go n (HsFunTy _ ty) = go (n+1) (unLoc ty) - go n (HsDocTy _ (L _ doc)) = M.singleton n doc + go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty + go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty) + go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc go _ _ = M.empty -- | All the sub declarations of a class (that we handle), ordered by @@ -535,10 +535,10 @@ ungroup group_ = mkDecls (typesigs . hs_valds) SigD group_ ++ mkDecls (valbinds . hs_valds) ValD group_ where - typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs + typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" - valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds + valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds valbinds _ = error "expected ValBindsOut" @@ -1068,7 +1068,7 @@ extractDecl declMap name decl , RecCon rec <- map (getConArgs . unLoc) (dd_cons (feqn_rhs d)) , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec) , L _ n <- ns - , selectorFieldOcc n == name + , extFieldOcc n == name ] in case matches of [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) @@ -1094,17 +1094,17 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy cxt typ) + ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) _ -> typ - typ'' = noLoc (HsQualTy (noLoc []) typ') + typ'' = noLoc (HsQualTy noExt (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 + longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs data_ty con | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn @@ -1113,16 +1113,16 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds - , L l n <- ns, selectorFieldOcc n == nm ] + , L l n <- ns, extFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = con_res_ty con - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs -- | Keep export items with docs. pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 6a0a20cf..c8d9cb7d 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -212,61 +212,61 @@ renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n - HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype - HsAppTy a b -> do + HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy a' b') + return (HsAppTy PlaceHolder a' b') - HsFunTy a b -> do + HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy a' b') + return (HsFunTy PlaceHolder a' b') - HsListTy ty -> return . HsListTy =<< renameLType ty - HsPArrTy ty -> return . HsPArrTy =<< renameLType ty - HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) - HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) + HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty + HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty) + HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2) - HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsSumTy ts -> HsSumTy <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts - HsOpTy a (L loc op) b -> do + HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (L loc op') b') + return (HsOpTy PlaceHolder a' (L loc op') b') - HsParTy ty -> return . HsParTy =<< renameLType ty + HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty - HsKindSig ty k -> do + HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig ty' k') + return (HsKindSig PlaceHolder ty' k') - HsDocTy ty doc -> do + HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy ty' doc') + return (HsDocTy PlaceHolder ty' doc') - HsTyLit x -> return (HsTyLit x) + HsTyLit _ x -> return (HsTyLit PlaceHolder x) - HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a - HsCoreTy a -> pure (HsCoreTy a) - HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b - HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b - HsSpliceTy _ _ -> error "renameType: HsSpliceTy" - HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a - HsAppsTy _ -> error "renameType: HsAppsTy" + HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a + (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) + HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b + HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b + HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a + HsAppsTy _ _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) @@ -275,13 +275,14 @@ renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) -renameLTyVarBndr (L loc (UserTyVar (L l n))) +renameLTyVarBndr (L loc (UserTyVar x (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) + ; return (L loc (UserTyVar x (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind - ; return (L loc (KindedTyVar (L lv n') kind')) } + ; return (L loc (KindedTyVar x (L lv n') kind')) } +renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr" renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do @@ -472,9 +473,10 @@ renameConDeclFieldField (L l (ConDeclField names t doc)) = do return $ L l (ConDeclField names' t' doc') renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) -renameLFieldOcc (L l (FieldOcc lbl sel)) = do +renameLFieldOcc (L l (FieldOcc sel lbl)) = do sel' <- rename sel - return $ L l (FieldOcc lbl sel') + return $ L l (FieldOcc sel' lbl) +renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 6d2888d3..18d93fae 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -28,20 +28,18 @@ import Data.Set (Set) import qualified Data.Set as Set -- | Instantiate all occurrences of given names with corresponding types. -specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => [(IdP name, HsType name)] -> a -> a +specialize :: Data a => [(Name, HsType GhcRn)] -> a -> a specialize specs = go where go :: forall x. Data x => x -> x - go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var + go = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var strip_kind_sig :: HsType name -> HsType name - strip_kind_sig (HsKindSig (L _ t) _) = t + strip_kind_sig (HsKindSig _ (L _ t) _) = t strip_kind_sig typ = typ - specialize_ty_var :: HsType name -> HsType name - specialize_ty_var (HsTyVar _ (L _ name')) + specialize_ty_var :: HsType GhcRn -> HsType GhcRn + specialize_ty_var (HsTyVar _ _ (L _ name')) | Just t <- Map.lookup name' spec_map = t specialize_ty_var typ = typ -- This is a tricky recursive definition that is guaranteed to terminate @@ -54,35 +52,33 @@ specialize specs = go -- -- Again, it is just a convenience function around 'specialize'. Note that -- length of type list should be the same as the number of binders. -specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => Data a - => LHsQTyVars name -> [HsType name] +specializeTyVarBndrs :: Data a + => LHsQTyVars GhcRn -> [HsType GhcRn] -> a -> a specializeTyVarBndrs bndrs typs = specialize $ zip bndrs' typs where bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs - bname (UserTyVar (L _ name)) = name - bname (KindedTyVar (L _ name) _) = name + bname (UserTyVar _ (L _ name)) = name + bname (KindedTyVar _ (L _ name) _) = name + bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs" -specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> PseudoFamilyDecl name - -> PseudoFamilyDecl name +specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> PseudoFamilyDecl GhcRn + -> PseudoFamilyDecl GhcRn specializePseudoFamilyDecl bndrs typs decl = decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)} -specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => LHsQTyVars name -> [HsType name] - -> Sig name - -> Sig name +specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] + -> Sig GhcRn + -> Sig GhcRn specializeSig bndrs typs (TypeSig lnames typ) = TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where - true_type :: HsType name + true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) - typ' :: HsType name + typ' :: HsType GhcRn typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type fv = foldr Set.union Set.empty . map freeVariables $ typs specializeSig _ _ sig = sig @@ -90,8 +86,7 @@ specializeSig _ _ sig = sig -- | Make all details of instance head (signatures, associated types) -- specialized to that particular instance type. -specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name)) - => InstHead name -> InstHead name +specializeInstHead :: InstHead GhcRn -> InstHead GhcRn specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } = ihd { ihdInstType = instType' } where @@ -110,27 +105,26 @@ specializeInstHead ihd = ihd -- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This -- can be fixed using 'sugar' function, that will turn such types into @[a]@ -- and @(a, b, c)@. -sugar :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> HsType name +sugar :: HsType GhcRn -> HsType GhcRn sugar = sugarOperators . sugarTuples . sugarLists -sugarLists :: NamedThing (IdP name) => HsType name -> HsType name -sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp +sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) + | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp where name' = getName name strName = occNameString . nameOccName $ name' sugarLists typ = typ -sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name +sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarTuples typ = aux [] typ where - aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp - aux apps (HsParTy (L _ typ')) = aux apps typ' - aux apps (HsTyVar _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps + aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp + aux apps (HsParTy _ (L _ typ')) = aux apps typ' + aux apps (HsTyVar _ _ (L _ name)) + | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -140,10 +134,10 @@ sugarTuples typ = aux _ _ = typ -sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name -sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb) +sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb where name' = getName name sugarOperators typ = typ @@ -208,15 +202,14 @@ setInternalOccName occ name = -- | Compute set of free variables of given type. -freeVariables :: forall name. (NamedThing (IdP name), DataId name) - => HsType name -> Set Name +freeVariables :: HsType GhcRn -> Set Name freeVariables = everythingWithState Set.empty Set.union query where - query term ctx = case cast term :: Maybe (HsType name) of - Just (HsForAllTy bndrs _) -> + query term ctx = case cast term :: Maybe (HsType GhcRn) of + Just (HsForAllTy _ bndrs _) -> (Set.empty, Set.union ctx (bndrsNames bndrs)) - Just (HsTyVar _ (L _ name)) + Just (HsTyVar _ _ (L _ name)) | getName name `Set.member` ctx -> (Set.empty, ctx) | otherwise -> (Set.singleton $ getName name, ctx) _ -> (Set.empty, ctx) @@ -231,8 +224,7 @@ freeVariables = -- different type variable than latter one. Applying 'rename' function -- will fix that type to be visually unambiguous again (making it something -- like @(a -> b0) -> b@). -rename :: (Eq (IdP name), DataId name, SetName (IdP name)) - => Set Name-> HsType name -> HsType name +rename :: Set Name -> HsType GhcRn -> HsType GhcRn rename fv typ = evalState (renameType typ) env where env = RenameEnv @@ -252,63 +244,58 @@ data RenameEnv name = RenameEnv } -renameType :: (Eq (IdP name), SetName (IdP name)) - => HsType name -> Rename (IdP name) (HsType name) -renameType (HsForAllTy bndrs lt) = - HsForAllTy +renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn) +renameType (HsForAllTy x bndrs lt) = + HsForAllTy x <$> mapM (located renameBinder) bndrs <*> renameLType lt -renameType (HsQualTy lctxt lt) = - HsQualTy +renameType (HsQualTy x lctxt lt) = + HsQualTy x <$> located renameContext lctxt <*> renameLType lt -renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name -renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la -renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr -renameType (HsListTy lt) = HsListTy <$> renameLType lt -renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt -renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt -renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt -renameType (HsOpTy la lop lb) = - HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb -renameType (HsParTy lt) = HsParTy <$> renameLType lt -renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt -renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb -renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk +renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name +renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la +renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr +renameType (HsListTy x lt) = HsListTy x <$> renameLType lt +renameType (HsPArrTy x lt) = HsPArrTy x <$> renameLType lt +renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt +renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt +renameType (HsOpTy x la lop lb) = + HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb +renameType (HsParTy x lt) = HsParTy x <$> renameLType lt +renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt +renameType (HsEqTy x la lb) = HsEqTy x <$> renameLType la <*> renameLType lb +renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk renameType t@(HsSpliceTy _ _) = pure t -renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc -renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt -renameType t@(HsRecTy _) = pure t -renameType t@(HsCoreTy _) = pure t -renameType (HsExplicitListTy ip ph ltys) = - HsExplicitListTy ip ph <$> renameLTypes ltys -renameType (HsExplicitTupleTy phs ltys) = - HsExplicitTupleTy phs <$> renameLTypes ltys -renameType t@(HsTyLit _) = pure t +renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc +renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt +renameType t@(HsRecTy _ _) = pure t +renameType t@(XHsType (NHsCoreTy _)) = pure t +renameType (HsExplicitListTy x ip ltys) = + HsExplicitListTy x ip <$> renameLTypes ltys +renameType (HsExplicitTupleTy x ltys) = + HsExplicitTupleTy x <$> renameLTypes ltys +renameType t@(HsTyLit _ _) = pure t renameType (HsWildCardTy wc) = pure (HsWildCardTy wc) -renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming" +renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming" -renameLType :: (Eq (IdP name), SetName (IdP name)) - => LHsType name -> Rename (IdP name) (LHsType name) +renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn) renameLType = located renameType -renameLTypes :: (Eq (IdP name), SetName (IdP name)) - => [LHsType name] -> Rename (IdP name) [LHsType name] +renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn] renameLTypes = mapM renameLType -renameContext :: (Eq (IdP name), SetName (IdP name)) - => HsContext name -> Rename (IdP name) (HsContext name) +renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn) renameContext = renameLTypes -renameBinder :: (Eq (IdP name), SetName (IdP name)) - => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name) -renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname -renameBinder (KindedTyVar lname lkind) = - KindedTyVar <$> located renameName lname <*> located renameType lkind - +renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn) +renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname +renameBinder (KindedTyVar x lname lkind) = + KindedTyVar x <$> located renameName lname <*> located renameType lkind +renameBinder (XTyVarBndr _) = error "haddock:renameBinder" -- | Core renaming logic. renameName :: (Eq name, SetName name) => name -> Rename name name @@ -363,5 +350,6 @@ located f (L loc e) = L loc <$> f e tyVarName :: HsTyVarBndr name -> IdP name -tyVarName (UserTyVar name) = unLoc name -tyVarName (KindedTyVar (L _ name) _) = name +tyVarName (UserTyVar _ name) = unLoc name +tyVarName (KindedTyVar _ (L _ name) _) = name +tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName" diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index af8904d3..b4b16d62 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -372,7 +372,7 @@ data PseudoFamilyDecl name = PseudoFamilyDecl } -mkPseudoFamilyDecl :: FamilyDecl name -> PseudoFamilyDecl name +mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p) mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl { pfdInfo = fdInfo , pfdLName = fdLName @@ -380,11 +380,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl , pfdKindSig = fdResultSig } where - mkType (KindedTyVar (L loc name) lkind) = - HsKindSig tvar lkind + mkType (KindedTyVar _ (L loc name) lkind) = + HsKindSig PlaceHolder tvar lkind where - tvar = L loc (HsTyVar NotPromoted (L loc name)) - mkType (UserTyVar name) = HsTyVar NotPromoted name + tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name)) + mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name + mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" -- | An instance head that may have documentation and a source location. @@ -662,3 +663,36 @@ type instance PostRn DocNameI DocName = DocName type instance PostTc DocNameI Kind = PlaceHolder type instance PostTc DocNameI Type = PlaceHolder type instance PostTc DocNameI Coercion = PlaceHolder + + +type instance XForAllTy DocNameI = PlaceHolder +type instance XQualTy DocNameI = PlaceHolder +type instance XTyVar DocNameI = PlaceHolder +type instance XAppsTy DocNameI = PlaceHolder +type instance XAppTy DocNameI = PlaceHolder +type instance XFunTy DocNameI = PlaceHolder +type instance XListTy DocNameI = PlaceHolder +type instance XPArrTy DocNameI = PlaceHolder +type instance XTupleTy DocNameI = PlaceHolder +type instance XSumTy DocNameI = PlaceHolder +type instance XOpTy DocNameI = PlaceHolder +type instance XParTy DocNameI = PlaceHolder +type instance XIParamTy DocNameI = PlaceHolder +type instance XEqTy DocNameI = PlaceHolder +type instance XKindSig DocNameI = PlaceHolder +type instance XSpliceTy DocNameI = PlaceHolder +type instance XDocTy DocNameI = PlaceHolder +type instance XBangTy DocNameI = PlaceHolder +type instance XRecTy DocNameI = PlaceHolder +type instance XExplicitListTy DocNameI = PlaceHolder +type instance XExplicitTupleTy DocNameI = PlaceHolder +type instance XTyLit DocNameI = PlaceHolder +type instance XWildCardTy DocNameI = HsWildCardInfo DocNameI +type instance XXType DocNameI = NewHsTypeX + +type instance XUserTyVar DocNameI = PlaceHolder +type instance XKindedTyVar DocNameI = PlaceHolder +type instance XXTyVarBndr DocNameI = PlaceHolder + +type instance XFieldOcc DocNameI = DocName +type instance XXFieldOcc DocNameI = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 1993fb5d..5de539c0 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -63,7 +63,7 @@ import Haddock.GhcUtils import GHC import Name import NameSet ( emptyNameSet ) -import HsTypes (selectorFieldOcc) +import HsTypes (extFieldOcc) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -136,11 +136,14 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_bndrs = tvs, hst_body = go ty }) + = L loc (HsForAllTy { hst_xforall = PlaceHolder + , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_ctxt = add_ctxt ctxt, hst_body = ty }) + = L loc (HsQualTy { hst_xqual = PlaceHolder + , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) + = L loc (HsQualTy { hst_xqual = PlaceHolder + , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) add_ctxt (L loc preds) = L loc (extra_pred : preds) @@ -149,7 +152,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -193,7 +196,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField fs _ _)) - = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs + = all (\f -> extFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing -- cgit v1.2.3 From a8ca2ae8737d29145fe57a7709e59be8cb7a00dc Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 2 Apr 2018 23:37:50 +0200 Subject: Match GHC for TTG implemented on HsBinds, D4581 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 +- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 6 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 24 ++++++------ haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 20 +++++----- haddock-api/src/Haddock/Convert.hs | 10 ++--- haddock-api/src/Haddock/GhcUtils.hs | 44 +++++++++++----------- haddock-api/src/Haddock/Interface/Create.hs | 16 ++++---- haddock-api/src/Haddock/Interface/Rename.hs | 20 +++++----- haddock-api/src/Haddock/Interface/Specialize.hs | 4 +- haddock-api/src/Haddock/Types.hs | 7 ++++ haddock-api/src/Haddock/Utils.hs | 10 ++--- 11 files changed, 86 insertions(+), 79 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 9e0b5102..09f62a19 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -138,7 +138,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppExport _ _ = [] ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] -ppSigWithDoc dflags (TypeSig names sig) subdocs +ppSigWithDoc dflags (TypeSig _ names sig) subdocs = concatMap mkDocSig names where mkDocSig n = concatMap (ppDocumentation dflags) (getDoc n) @@ -262,7 +262,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) name = out dflags $ map unL $ getConNames con ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 3d7575eb..19d638d9 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -114,7 +114,7 @@ binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) _ -> empty pat term = case cast term of @@ -150,7 +150,7 @@ decls (group, _, _, _) = concatMap ($ group) GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) + (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of @@ -169,7 +169,7 @@ decls (group, _, _, _) = concatMap ($ group) Just (field :: GHC.ConDeclField GHC.GhcRn) -> map (decl . fmap GHC.extFieldOcc) $ GHC.cd_fld_names field Nothing -> empty - sig (GHC.L _ (GHC.TypeSig names _)) = map decl names + sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names sig _ = [] decl (GHC.L sspan name) = (sspan, RtkDecl name) tyref (GHC.L sspan name) = (sspan, RtkType name) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 1229a8d3..4535979e 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -216,7 +216,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -257,8 +257,8 @@ declNames :: LHsDecl DocNameI ) declNames (L _ decl) = case decl of TyClD d -> (empty, [tcdName d]) - SigD (TypeSig lnames _ ) -> (empty, map unLoc lnames) - SigD (PatSynSig lnames _) -> (text "pattern", map unLoc lnames) + SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -300,13 +300,13 @@ ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of -- TyClD d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD (TypeSig lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode - SigD (PatSynSig lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ -> empty + DerivD _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False @@ -548,7 +548,7 @@ ppClassDecl instances doc subdocs methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ vcat [ ppFunSig doc names (hsSigWcType typ) unicode - | L _ (TypeSig lnames typ) <- lsigs + | L _ (TypeSig _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat [ empty <-> ppSideBySidePat lnames typ d unicode - | (SigD (PatSynSig lnames typ), d) <- pats + | (SigD (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index a4f2a4a5..5f253cbd 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -58,9 +58,9 @@ ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdoc 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 + SigD (TypeSig _ lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigType lty) fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml @@ -513,7 +513,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t [ ppFunSig summary links loc doc names (hsSigWcType typ) [] splice unicode qual - | L _ (TypeSig lnames typ) <- sigs + | L _ (TypeSig _ lnames typ) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that @@ -561,7 +561,7 @@ ppClassDecl summary links instances fixities loc d subdocs methodBit = subMethods [ ppFunSig summary links loc doc names (hsSigType typ) subfixs splice unicode qual - | L _ (ClassOpSig _ lnames typ) <- lsigs + | L _ (ClassOpSig _ _ lnames typ) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities @@ -570,15 +570,15 @@ ppClassDecl summary links instances fixities loc d subdocs -- 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 + minimalBit = case [ s | MinimalSig _ _ (L _ s) <- sigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | L _ (Var (L _ n)) <- xs] == - sort [getName n | TypeSig ns _ <- sigs, L _ n <- ns] + sort [getName n | TypeSig _ ns _ <- sigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] == - [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] + [getName n' | L _ (TypeSig _ ns _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing @@ -679,7 +679,7 @@ ppInstanceSigs :: LinksInfo -> Splice -> Unicode -> Qualification -> [Sig DocNameI] -> [Html] ppInstanceSigs links splice unicode qual sigs = do - TypeSig lnames typ <- sigs + 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 @@ -746,7 +746,7 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig lnames typ),_) <- pats + | (SigD (PatSynSig _ lnames typ),_) <- pats ] @@ -793,7 +793,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats patternBit = subPatterns qual [ ppSideBySidePat subfixs unicode qual lnames typ d - | (SigD (PatSynSig lnames typ), d) <- pats + | (SigD (PatSynSig _ lnames typ), d) <- pats , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities ] diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fac448a2..fd9f0089 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -85,7 +85,7 @@ tyThingToLHsDecl t = case t of , tcdFDs = map (\ (l,r) -> noLoc (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl - , tcdSigs = noLoc (MinimalSig NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : + , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) (classMethods cl) , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -102,11 +102,11 @@ tyThingToLHsDecl t = case t of ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc] (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -331,10 +331,10 @@ synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) +synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) +synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 48a9f99e..14111a6a 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -74,30 +74,30 @@ getInstLoc (TyFamInstD (TyFamInstDecl -- foo, bar :: Types.. -- but only one of the names is exported and we have to change the -- type signature to only include the exported names. -filterLSigNames :: (IdP name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames :: (IdP (GhcPass p) -> Bool) -> LSig (GhcPass p) -> Maybe (LSig (GhcPass p)) filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) -filterSigNames :: (IdP name -> Bool) -> Sig name -> Maybe (Sig name) -filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig -filterSigNames p (FixSig (FixitySig ns ty)) = +filterSigNames :: (IdP (GhcPass p) -> Bool) -> Sig (GhcPass p) -> Maybe (Sig (GhcPass p)) +filterSigNames p orig@(SpecSig _ n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig _ n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (FixSig _ (FixitySig _ ns ty)) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (FixSig (FixitySig filtered ty)) -filterSigNames _ orig@(MinimalSig _ _) = Just orig -filterSigNames p (TypeSig ns ty) = + filtered -> Just (FixSig noExt (FixitySig noExt filtered ty)) +filterSigNames _ orig@(MinimalSig _ _ _) = Just orig +filterSigNames p (TypeSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (TypeSig filtered ty) -filterSigNames p (ClassOpSig is_default ns ty) = + filtered -> Just (TypeSig noExt filtered ty) +filterSigNames p (ClassOpSig _ is_default ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (ClassOpSig is_default filtered ty) -filterSigNames p (PatSynSig ns ty) = + filtered -> Just (ClassOpSig noExt is_default filtered ty) +filterSigNames p (PatSynSig _ ns ty) = case filter (p . unLoc) ns of [] -> Nothing - filtered -> Just (PatSynSig filtered ty) -filterSigNames _ _ = Nothing + filtered -> Just (PatSynSig noExt filtered ty) +filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name ifTrueJust True = Just @@ -107,13 +107,13 @@ sigName :: LSig name -> [IdP name] sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [IdP name] -sigNameNoLoc (TypeSig ns _) = map unLoc ns -sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns -sigNameNoLoc (PatSynSig ns _) = map unLoc ns -sigNameNoLoc (SpecSig n _ _) = [unLoc n] -sigNameNoLoc (InlineSig n _) = [unLoc n] -sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns -sigNameNoLoc _ = [] +sigNameNoLoc (TypeSig _ ns _) = map unLoc ns +sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns +sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns +sigNameNoLoc (SpecSig _ n _ _) = [unLoc n] +sigNameNoLoc (InlineSig _ n _) = [unLoc n] +sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns +sigNameNoLoc _ = [] -- | Was this signature given by the user? isUserLSig :: LSig name -> Bool @@ -258,7 +258,7 @@ instance Parent (TyClDecl GhcRn) where $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ] | otherwise = [] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 88b8bc67..c119f3c3 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -481,9 +481,9 @@ conArgDocs con = case getConArgs con of -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString -declTypeDocs (SigD (TypeSig _ ty)) = typeDocs (unLoc (hsSigWcType ty)) -declTypeDocs (SigD (ClassOpSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (SigD (PatSynSig _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty)) declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) declTypeDocs _ = M.empty @@ -519,7 +519,7 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f) - | L _ (FixitySig ns f) <- hs_fixds group_, + | L _ (FixitySig _ ns f) <- hs_fixds group_, L _ n <- ns ] @@ -729,7 +729,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef + let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ @@ -1022,7 +1022,7 @@ extractDecl declMap name decl matchesMethod = [ lsig | lsig <- tcdSigs d - , ClassOpSig False _ _ <- pure $ unLoc lsig + , ClassOpSig _ False _ _ <- pure $ unLoc lsig -- Note: exclude `default` declarations (see #505) , name `elem` sigName lsig ] @@ -1097,7 +1097,7 @@ extractPatternSyn nm t tvs cons = ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) _ -> typ typ'' = noLoc (HsQualTy noExt (noLoc []) typ') - in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') + in PatSynSig noExt [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs @@ -1113,7 +1113,7 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> - L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) + L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index c8d9cb7d..0652ae47 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -480,24 +480,24 @@ renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc" renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of - TypeSig lnames ltype -> do + TypeSig _ lnames ltype -> do lnames' <- mapM renameL lnames ltype' <- renameLSigWcType ltype - return (TypeSig lnames' ltype') - ClassOpSig is_default lnames sig_ty -> do + return (TypeSig noExt lnames' ltype') + ClassOpSig _ is_default lnames sig_ty -> do lnames' <- mapM renameL lnames ltype' <- renameLSigType sig_ty - return (ClassOpSig is_default lnames' ltype') - PatSynSig lnames sig_ty -> do + return (ClassOpSig noExt is_default lnames' ltype') + PatSynSig _ lnames sig_ty -> do lnames' <- mapM renameL lnames sig_ty' <- renameLSigType sig_ty - return $ PatSynSig lnames' sig_ty' - FixSig (FixitySig lnames fixity) -> do + return $ PatSynSig noExt lnames' sig_ty' + FixSig _ (FixitySig _ lnames fixity) -> do lnames' <- mapM renameL lnames - return $ FixSig (FixitySig lnames' fixity) - MinimalSig src (L l s) -> do + return $ FixSig noExt (FixitySig noExt lnames' fixity) + MinimalSig _ src (L l s) -> do s' <- traverse renameL s - return $ MinimalSig src (L l s') + return $ MinimalSig noExt src (L l s') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 18d93fae..b84a676f 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -73,8 +73,8 @@ specializePseudoFamilyDecl bndrs typs decl = specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn] -> Sig GhcRn -> Sig GhcRn -specializeSig bndrs typs (TypeSig lnames typ) = - TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) +specializeSig bndrs typs (TypeSig _ lnames typ) = + TypeSig noExt lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}}) where true_type :: HsType GhcRn true_type = unLoc (hsSigWcType typ) diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b4b16d62..2234894c 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -696,3 +696,10 @@ type instance XXTyVarBndr DocNameI = PlaceHolder type instance XFieldOcc DocNameI = DocName type instance XXFieldOcc DocNameI = PlaceHolder + +type instance XFixitySig DocNameI = PlaceHolder +type instance XFixSig DocNameI = PlaceHolder +type instance XPatSynSig DocNameI = PlaceHolder +type instance XClassOpSig DocNameI = PlaceHolder +type instance XTypeSig DocNameI = PlaceHolder +type instance XMinimalSig DocNameI = PlaceHolder diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 5de539c0..1ebf7ffa 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -131,18 +131,18 @@ mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature -addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) - = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) +addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype)) + = L pos (TypeSig noExt lname (mkEmptySigWcType (go (hsSigType ltype)))) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_xforall = PlaceHolder + = L loc (HsForAllTy { hst_xforall = noExt , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) -- cgit v1.2.3 From 271a9cb0c7a070deef8df2d4fb54ebe47a0bf560 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 19 Apr 2018 14:04:04 +0200 Subject: Match changes in GHC for TTG --- haddock-api/src/Haddock/Backends/Hoogle.hs | 21 +-- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 18 +-- haddock-api/src/Haddock/Backends/LaTeX.hs | 43 +++--- haddock-api/src/Haddock/Backends/Xhtml.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 49 ++++--- haddock-api/src/Haddock/Convert.hs | 77 +++++----- haddock-api/src/Haddock/GhcUtils.hs | 44 +++--- .../src/Haddock/Interface/AttachInstances.hs | 2 +- haddock-api/src/Haddock/Interface/Create.hs | 118 ++++++++-------- haddock-api/src/Haddock/Interface/Rename.hs | 155 ++++++++++++--------- haddock-api/src/Haddock/Interface/Specialize.hs | 6 +- haddock-api/src/Haddock/Types.hs | 124 ++++++++++------- haddock-api/src/Haddock/Utils.hs | 26 ++-- 13 files changed, 386 insertions(+), 299 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 09f62a19..2c7be079 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -126,12 +126,12 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemFixities = fixities } = ppDocumentation dflags dc ++ f decl where - f (TyClD d@DataDecl{}) = ppData dflags d subdocs - f (TyClD d@SynDecl{}) = ppSynonym dflags d - f (TyClD d@ClassDecl{}) = ppClass dflags d subdocs - f (ForD (ForeignImport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (ForD (ForeignExport name typ _ _)) = [pp_sig dflags [name] (hsSigType typ)] - f (SigD sig) = ppSig dflags sig ++ ppFixities + f (TyClD _ d@DataDecl{}) = ppData dflags d subdocs + f (TyClD _ d@SynDecl{}) = ppSynonym dflags d + f (TyClD _ d@ClassDecl{}) = ppClass dflags d subdocs + f (ForD _ (ForeignImport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (ForD _ (ForeignExport _ name typ _)) = [pp_sig dflags [name] (hsSigType typ)] + f (SigD _ sig) = ppSig dflags sig ++ ppFixities f _ = [] ppFixities = concatMap (ppFixity dflags) fixities @@ -189,7 +189,7 @@ ppClass dflags decl subdocs = , tcdTyVars = feqn_pats tfe , tcdFixity = feqn_fixity tfe , tcdRhs = feqn_rhs tfe - , tcdFVs = emptyNameSet + , tcdSExt = emptyNameSet } @@ -241,8 +241,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy PlaceHolder x y) - apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y) + funs = foldr1 (\x y -> reL $ HsFunTy NoExt x y) + apps = foldl1 (\x y -> reL $ HsAppTy NoExt x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -250,7 +250,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $ + resType = apps $ map (reL . HsTyVar NoExt NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@(ConDeclGADT { }) @@ -260,6 +260,7 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { }) typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty) name = out dflags $ map unL $ getConNames con +ppCtor _ _ _ XConDecl {} = panic "haddock:ppCtor" ppFixity :: DynFlags -> (Name, Fixity) -> [String] ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExt [noLoc name] fixity) :: FixitySig GhcRn)] diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 19d638d9..56137f51 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -12,6 +12,7 @@ import qualified Haddock.Syb as Syb import Haddock.Backends.Hyperlinker.Types import qualified GHC +import qualified Outputable as GHC import Control.Applicative import Control.Monad (guard) @@ -146,9 +147,10 @@ decls (group, _, _, _) = concatMap ($ group) where typ (GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name - GHC.SynDecl name _ _ _ _ -> pure . decl $ name - GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam + GHC.SynDecl _ name _ _ _ -> pure . decl $ name + GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs + GHC.XTyClDecl {} -> GHC.panic "haddock:decls" fun term = case cast term of (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) @@ -159,10 +161,10 @@ decls (group, _, _, _) = concatMap ($ group) ++ everythingInRenamedSource fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD (GHC.DataFamInstDecl eqn)) + (Just ((GHC.DataFamInstD _ (GHC.DataFamInstDecl eqn)) :: GHC.InstDecl GHC.GhcRn)) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn - (Just (GHC.TyFamInstD (GHC.TyFamInstDecl eqn))) -> + (Just (GHC.TyFamInstD _ (GHC.TyFamInstDecl eqn))) -> pure . tyref $ GHC.feqn_tycon $ GHC.hsib_body eqn _ -> empty fld term = case cast term of @@ -183,10 +185,10 @@ imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v - (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t - (Just (GHC.IEThingWith t _ vs _fls)) -> + (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v + (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t + (Just (GHC.IEThingWith _ t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs _ -> empty typ (GHC.L sspan name) = (sspan, RtkType name) diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 4535979e..1b2515fa 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -216,7 +216,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocNameI -> Maybe ([DocName], HsType DocNameI) -isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig _ lnames t)) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD _ (TypeSig _ lnames t)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, unLoc (hsSigWcType t)) isSimpleSig _ = Nothing @@ -256,11 +256,11 @@ declNames :: LHsDecl DocNameI , [DocName] -- ^ names being declared ) declNames (L _ decl) = case decl of - TyClD d -> (empty, [tcdName d]) - SigD (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) - SigD (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) - ForD (ForeignImport (L _ n) _ _ _) -> (empty, [n]) - ForD (ForeignExport (L _ n) _ _ _) -> (empty, [n]) + TyClD _ d -> (empty, [tcdName d]) + SigD _ (TypeSig _ lnames _ ) -> (empty, map unLoc lnames) + SigD _ (PatSynSig _ lnames _) -> (text "pattern", map unLoc lnames) + ForD _ (ForeignImport _ (L _ n) _ _) -> (empty, [n]) + ForD _ (ForeignExport _ (L _ n) _ _) -> (empty, [n]) _ -> error "declaration not supported by declNames" @@ -293,20 +293,20 @@ ppDecl :: LHsDecl DocNameI -- ^ decl to print -> LaTeX ppDecl decl pats (doc, fnArgsDoc) instances subdocs _fxts = case unLoc decl of - TyClD d@FamDecl {} -> ppTyFam False doc d unicode - TyClD d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode - TyClD d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode + TyClD _ d@FamDecl {} -> ppTyFam False doc d unicode + TyClD _ d@DataDecl {} -> ppDataDecl pats instances subdocs (Just doc) d unicode + TyClD _ d@SynDecl {} -> ppTySyn (doc, fnArgsDoc) d unicode -- Family instances happen via FamInst now --- TyClD d@TySynonym{} +-- TyClD _ d@TySynonym{} -- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode -- Family instances happen via FamInst now - TyClD d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode - SigD (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode - SigD (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode - ForD d -> ppFor (doc, fnArgsDoc) d unicode - InstD _ -> empty - DerivD _ -> empty - _ -> error "declaration not supported by ppDecl" + TyClD _ d@ClassDecl{} -> ppClassDecl instances doc subdocs d unicode + SigD _ (TypeSig _ lnames ty) -> ppFunSig (doc, fnArgsDoc) (map unLoc lnames) (hsSigWcType ty) unicode + SigD _ (PatSynSig _ lnames ty) -> ppLPatSig (doc, fnArgsDoc) (map unLoc lnames) ty unicode + ForD _ d -> ppFor (doc, fnArgsDoc) d unicode + InstD _ _ -> empty + DerivD _ _ -> empty + _ -> error "declaration not supported by ppDecl" where unicode = False @@ -318,7 +318,7 @@ ppTyFam _ _ _ _ = ppFor :: DocForDecl DocName -> ForeignDecl DocNameI -> Bool -> LaTeX -ppFor doc (ForeignImport (L _ name) typ _ _) unicode = +ppFor doc (ForeignImport _ (L _ name) typ _) unicode = ppFunSig doc [name] (hsSigType typ) unicode ppFor _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" -- error "foreign declarations are currently not supported by --latex" @@ -647,7 +647,7 @@ ppDataDecl pats instances subdocs doc dataDecl unicode = text "\\enspace" <+> emph (text "Bundled Patterns") <> text "\\par" $$ text "\\haddockbeginconstrs" $$ vcat [ empty <-> ppSideBySidePat lnames typ d unicode - | (SigD (PatSynSig _ lnames typ), d) <- pats + | (SigD _ (PatSynSig _ lnames typ), d) <- pats ] $$ text "\\end{tabulary}\\par" @@ -726,6 +726,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- ++AZ++ make this prepend "{..}" when it is a record style GADT , ppLType unicode (getGADTConType con) ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -759,6 +760,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = [ l <+> text "\\enspace" <+> r | (l,r) <- ppSubSigLike unicode (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) ] + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" -- don't use "con_doc con", in case it's reconstructed from a .hi file, @@ -771,13 +773,14 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocNameI -> LaTeX -ppSideBySideField subdocs unicode (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) = decltt (cat (punctuate comma (map (ppBinder . rdrNameOcc . unLoc . 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 (extFieldOcc $ unLoc $ head names) subdocs >>= fmap _doc . combineDocumentation . fst +ppSideBySideField _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" -- | Pretty-print a bundled pattern synonym diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 00937245..464c166b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -663,7 +663,7 @@ numberSectionHeadings = go 1 processExport :: Bool -> LinksInfo -> Bool -> Qualification -> ExportItem DocNameI -> Maybe Html -processExport _ _ _ _ ExportDecl { expItemDecl = 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 (Just id0) qual (mkMeta doc) processExport summary links unicode qual (ExportDecl decl pats doc subdocs insts fixities splice) diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 5f253cbd..8ac3d91b 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -39,6 +39,7 @@ import GHC.Exts import Name import BooleanFormula import RdrName ( rdrNameOcc ) +import Outputable ( panic ) -- | Pretty print a declaration ppDecl :: Bool -- ^ print summary info only @@ -54,18 +55,18 @@ ppDecl :: Bool -- ^ print summary info only -> Qualification -> Html 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 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 + 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 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 (hsSigWcType lty) fixities splice unicode qual - SigD (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames + SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames (hsSigType lty) fixities splice unicode qual - ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual - InstD _ -> noHtml - DerivD _ -> noHtml - _ -> error "declaration not supported by ppDecl" + ForD _ d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + InstD _ _ -> noHtml + DerivD _ _ -> noHtml + _ -> error "declaration not supported by ppDecl" ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> @@ -225,7 +226,7 @@ tyvarNames = map (getName . hsLTyVarName) . hsQTvExplicit ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocNameI -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html -ppFor summary links loc doc (ForeignImport (L _ name) typ _ _) fixities +ppFor summary links loc doc (ForeignImport _ (L _ name) typ _) fixities splice unicode qual = ppFunSig summary links loc doc [name] (hsSigType typ) fixities splice unicode qual ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" @@ -318,12 +319,14 @@ ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info ClosedTypeFamily _ -> keyword "where ..." _ -> mempty ) +ppTyFamHeader _ _ (XFamilyDecl _) _ _ = panic "haddock;ppTyFamHeader" ppResultSig :: FamilyResultSig DocNameI -> Unicode -> Qualification -> Html ppResultSig result unicode qual = case result of - NoSig -> noHtml - KindSig kind -> dcolon unicode <+> ppLKind unicode qual kind - TyVarSig (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + NoSig _ -> noHtml + KindSig _ kind -> dcolon unicode <+> ppLKind unicode qual kind + TyVarSig _ (L _ bndr) -> equals <+> ppHsTyVarBndr unicode qual bndr + XFamilyResultSig _ -> panic "haddock:ppResultSig" ppPseudoFamilyHeader :: Unicode -> Qualification -> PseudoFamilyDecl DocNameI -> Html @@ -367,6 +370,8 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual HideEmptyContexts (unLoc rhs) , Nothing, [] ) + ppTyFamEqn (XHsImplicitBndrs _) = panic "haddock:ppTyFam" + ppTyFamEqn (HsIB { hsib_body = XFamEqn _}) = panic "haddock:ppTyFam" @@ -399,6 +404,7 @@ ppAssocType summ links doc (L loc decl) fixities splice unicode qual = ppFamDeclBinderWithVars :: Bool -> Unicode -> Qualification -> FamilyDecl DocNameI -> Html ppFamDeclBinderWithVars summ unicode qual (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = ppAppDocNameTyVarBndrs summ unicode qual (unLoc lname) (hsq_explicit tvs) +ppFamDeclBinderWithVars _ _ _ (XFamilyDecl _) = panic "haddock:ppFamDeclBinderWithVars" -- | Print a newtype / data binder and its variables ppDataBinderWithVars :: Bool -> Unicode -> Qualification -> TyClDecl DocNameI -> Html @@ -740,13 +746,14 @@ ppShortDataDecl summary dataInst dataDecl pats unicode qual isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False pats1 = [ hsep [ keyword "pattern" , hsep $ punctuate comma $ map (ppBinder summary . getOccName) lnames , dcolon unicode , ppPatSigType unicode qual (hsSigType typ) ] - | (SigD (PatSynSig _ lnames typ),_) <- pats + | (SigD _ (PatSynSig _ lnames typ),_) <- pats ] @@ -772,6 +779,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats isH98 = case unLoc (head cons) of ConDeclH98 {} -> True ConDeclGADT{} -> False + XConDecl{} -> False header_ = topDeclElem links loc splice [docname] $ ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix @@ -793,7 +801,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats patternBit = subPatterns qual [ ppSideBySidePat subfixs unicode qual lnames typ d - | (SigD (PatSynSig _ lnames typ), d) <- pats + | (SigD _ (PatSynSig _ lnames typ), d) <- pats , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) (map unLoc lnames)) fixities ] @@ -854,6 +862,7 @@ ppShortConstrParts summary dataInst con unicode qual , noHtml , noHtml ) + XConDecl {} -> panic "haddock:ppShortConstrParts" where occ = map (nameOccName . getName . unLoc) $ getConNames con @@ -923,6 +932,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) , ppLType unicode qual HideEmptyContexts (getGADTConType con) , fixity ] + XConDecl{} -> panic "haddock:ppSideBySideConstr" fieldPart = case (con, getConArgs con) of -- Record style GADTs @@ -951,6 +961,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) ConDeclGADT{} -> ppSubSigLike unicode qual (unLoc (getGADTConType con)) argDocs subdocs (dcolon unicode) HideEmptyContexts + XConDecl{} -> panic "haddock:doConstrArgsWithDocs" -- 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. @@ -980,7 +991,7 @@ ppConstrHdr forall_ tvs ctxt unicode qual = ppForall +++ ppCtxt -- | Pretty-print a record field ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocNameI -> SubDecl -ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = +ppSideBySideField subdocs unicode qual (ConDeclField _ names ltype _) = ( hsep (punctuate comma [ ppBinder False (rdrNameOcc field) | L _ name <- names , let field = (unLoc . rdrNameFieldOcc) name @@ -994,12 +1005,14 @@ ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) = -- 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 (extFieldOcc $ unLoc $ head names) subdocs >>= combineDocumentation . fst +ppSideBySideField _ _ _ (XConDeclField _) = panic "haddock:ppSideBySideField" ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocNameI -> Html -ppShortField summary unicode qual (ConDeclField names ltype _) +ppShortField summary unicode qual (ConDeclField _ names ltype _) = hsep (punctuate comma (map ((ppBinder summary) . rdrNameOcc . unLoc . rdrNameFieldOcc . unLoc) names)) <+> dcolon unicode <+> ppLType unicode qual HideEmptyContexts ltype +ppShortField _ _ _ (XConDeclField _) = panic "haddock:ppShortField" -- | Pretty print an expanded pattern (for bundled patterns) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index fd9f0089..b4804758 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP, PatternGuards #-} +{-# LANGUAGE CPP, PatternGuards, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Convert @@ -62,14 +62,14 @@ tyThingToLHsDecl t = case t of -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl d) = return $ noLoc d + extractFamilyDecl (FamDecl _ d) = return $ noLoc d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" @@ -77,7 +77,7 @@ tyThingToLHsDecl t = case t of atFamDecls = map extractFamilyDecl (rights atTyClDecls) tyClErrors = lefts atTyClDecls famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl + in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) @@ -93,20 +93,20 @@ tyThingToLHsDecl t = case t of , tcdATs = rights atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point - , tcdFVs = placeHolderNamesTc } + , tcdCExt = placeHolderNamesTc } | otherwise - -> synifyTyCon Nothing tc >>= allOK . TyClD + -> synifyTyCon Nothing tc >>= allOK . TyClD noExt -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function: - AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig noExt [synifyName dc] + AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] (synifySigWcType ImplicitizeForAll (dataConUserType dc))) AConLike (PatSynCon ps) -> - allOK . SigD $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) + allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) where withErrs e x = return (e, x) allOK x = return (mempty, x) @@ -119,9 +119,10 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats hs_rhs = synifyType WithinType rhs - in HsIB { hsib_vars = map tyVarName tkvs - , hsib_closed = True - , hsib_body = FamEqn { feqn_tycon = name + in HsIB { hsib_ext = HsIBRn { hsib_vars = map tyVarName tkvs + , hsib_closed = True } + , hsib_body = FamEqn { feqn_ext = noExt + , feqn_tycon = name , feqn_pats = annot_typats , feqn_fixity = Prefix , feqn_rhs = hs_rhs } } @@ -132,13 +133,13 @@ synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax - = return $ InstD - $ TyFamInstD + = return $ InstD noExt + $ TyFamInstD noExt $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error - = synifyTyCon (Just ax) tc >>= return . TyClD + = synifyTyCon (Just ax) tc >>= return . TyClD noExt | otherwise = Left "synifyAxiom: closed/open family confusion" @@ -153,14 +154,17 @@ synifyTyCon _coax tc let mk_hs_tv realKind fakeTyVar = noLoc $ KindedTyVar noExt (noLoc (getName fakeTyVar)) (synifyKindSig realKind) - in HsQTvs { hsq_implicit = [] -- No kind polymorphism + in HsQTvs { hsq_ext = + HsQTvsRn { hsq_implicit = [] -- No kind polymorphism + , hsq_dependent = emptyNameSet } , hsq_explicit = zipWith mk_hs_tv (fst (splitFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * - , hsq_dependent = emptyNameSet } + } , tcdFixity = Prefix - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither + , tcdDataDefn = HsDataDefn { dd_ext = noExt + , dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing @@ -168,8 +172,7 @@ synifyTyCon _coax tc -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = noLoc [] } - , tcdDataCusk = False - , tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } synifyTyCon _coax tc | Just flav <- famTyConFlav_maybe tc @@ -190,8 +193,9 @@ synifyTyCon _coax tc -> mkFamDecl DataFamily where resultVar = famTcResVar tc - mkFamDecl i = return $ FamDecl $ - FamilyDecl { fdInfo = i + mkFamDecl i = return $ FamDecl noExt $ + FamilyDecl { fdExt = noExt + , fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConVisibleTyVars tc) , fdFixity = Prefix @@ -204,11 +208,11 @@ synifyTyCon _coax tc synifyTyCon coax tc | Just ty <- synTyConRhs_maybe tc - = return $ SynDecl { tcdLName = synifyName tc + = return $ SynDecl { tcdSExt = emptyNameSet + , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty - , tcdFVs = placeHolderNamesTc } + , tcdRhs = synifyType WithinType ty } | otherwise = -- (closed) newtype and data let @@ -241,7 +245,8 @@ synifyTyCon coax tc cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = noLoc [] - defn = HsDataDefn { dd_ND = alg_nd + defn = HsDataDefn { dd_ext = noExt + , dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = fmap synifyKindSig kindSig @@ -251,7 +256,7 @@ synifyTyCon coax tc [] -> return $ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdFixity = Prefix , tcdDataDefn = defn - , tcdDataCusk = False, tcdFVs = placeHolderNamesTc } + , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity @@ -264,9 +269,9 @@ synifyInjectivityAnn (Just lhs) tvs (Injective inj) = synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = - noLoc $ KindSig (synifyKindSig kind) + noLoc $ KindSig noExt (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = - noLoc $ TyVarSig (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) + noLoc $ TyVarSig noExt (noLoc $ KindedTyVar noExt (noLoc name) (synifyKindSig kind)) -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -297,7 +302,7 @@ synifyDataCon use_gadt_syntax dc = field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys con_decl_field fl synTy = noLoc $ - ConDeclField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy + ConDeclField noExt [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy Nothing hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> Left "synifyDataCon: contradiction!" @@ -311,7 +316,8 @@ synifyDataCon use_gadt_syntax dc = \hat -> if use_gadt_syntax then return $ noLoc $ - ConDeclGADT { con_names = [name] + ConDeclGADT { con_g_ext = noExt + , con_names = [name] , con_forall = True , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) , con_mb_cxt = Just ctx @@ -319,7 +325,8 @@ synifyDataCon use_gadt_syntax dc = , con_res_ty = synifyType WithinType res_ty , con_doc = Nothing } else return $ noLoc $ - ConDeclH98 { con_name = name + ConDeclH98 { con_ext = noExt + , con_name = name , con_forall = True , con_ex_tvs = map synifyTyVar ex_tvs , con_mb_cxt = Just ctx @@ -341,9 +348,9 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn -synifyTyVars ktvs = HsQTvs { hsq_implicit = [] - , hsq_explicit = map synifyTyVar ktvs - , hsq_dependent = emptyNameSet } +synifyTyVars ktvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = [] + , hsq_dependent = emptyNameSet } + , hsq_explicit = map synifyTyVar ktvs } synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv @@ -546,7 +553,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do - (Right (FamDecl fam)) <- map (synifyTyCon Nothing) $ classATs cls + (Right (FamDecl _ fam)) <- map (synifyTyCon Nothing) $ classATs cls pure $ mkPseudoFamilyDecl fam } } diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 14111a6a..2d254414 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -47,28 +47,36 @@ isConSym = isLexConSym . occNameFS getMainDeclBinder :: HsDecl name -> [IdP name] -getMainDeclBinder (TyClD d) = [tcdName d] -getMainDeclBinder (ValD d) = +getMainDeclBinder (TyClD _ d) = [tcdName d] +getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of [] -> [] (name:_) -> [name] -getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] -getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] +getMainDeclBinder (SigD _ d) = sigNameNoLoc d +getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name] +getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. getInstLoc :: InstDecl name -> SrcSpan -getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) -getInstLoc (DataFamInstD (DataFamInstDecl +getInstLoc (ClsInstD _ (ClsInstDecl { cid_poly_ty = ty })) = getLoc (hsSigType ty) +getInstLoc (DataFamInstD _ (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}})) = l -getInstLoc (TyFamInstD (TyFamInstDecl +getInstLoc (TyFamInstD _ (TyFamInstDecl -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}})) = l +getInstLoc (ClsInstD _ (XClsInstDecl _)) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "getInstLoc" +getInstLoc (XInstDecl _) = panic "getInstLoc" +getInstLoc (DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" +getInstLoc (TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "getInstLoc" + + -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types.. @@ -124,16 +132,16 @@ isUserLSig _ = False isClassD :: HsDecl a -> Bool -isClassD (TyClD d) = isClassDecl d +isClassD (TyClD _ d) = isClassDecl d isClassD _ = False isValD :: HsDecl a -> Bool -isValD (ValD _) = True +isValD (ValD _ _) = True isValD _ = False declATs :: HsDecl a -> [IdP a] -declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d +declATs (TyClD _ d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d declATs _ = [] @@ -165,13 +173,13 @@ getGADTConType (ConDeclGADT { con_forall = has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -184,6 +192,7 @@ getGADTConType (ConDeclGADT { con_forall = has_forall getGADTConType (ConDeclH98 {}) = panic "getGADTConType" -- Should only be called on ConDeclGADT +getGADTConType (XConDecl {}) = panic "getGADTConType" -- ------------------------------------- @@ -196,13 +205,13 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall , con_qvars = qtvs , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty }) - | has_forall = noLoc (HsForAllTy { hst_xforall = PlaceHolder + | has_forall = noLoc (HsForAllTy { hst_xforall = NoExt , hst_bndrs = hsQTvExplicit qtvs , hst_body = theta_ty }) | otherwise = theta_ty where theta_ty | Just theta <- mcxt - = noLoc (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = theta, hst_body = tau_ty }) + = noLoc (HsQualTy { hst_xqual = NoExt, hst_ctxt = theta, hst_body = tau_ty }) | otherwise = tau_ty @@ -213,8 +222,9 @@ getGADTConTypeG (ConDeclGADT { con_forall = has_forall mkFunTy a b = noLoc (HsFunTy noExt a b) -getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConType" +getGADTConTypeG (ConDeclH98 {}) = panic "getGADTConTypeG" -- Should only be called on ConDeclGADT +getGADTConTypeG (XConDecl {}) = panic "getGADTConTypeG" ------------------------------------------------------------------------------- -- * Located @@ -286,7 +296,7 @@ parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration parents :: Name -> HsDecl GhcRn -> [Name] -parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents n (TyClD _ d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 4fd9d264..286907e5 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -87,7 +87,7 @@ attachToExportItem -> Ghc (ExportItem GhcRn) attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of - e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do + e@ExportDecl { expItemDecl = L eSpan (TyClD _ d) } -> do insts <- let mb_instances = lookupNameEnv index (tcdName d) cls_instances = maybeToList mb_instances >>= fst diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index c119f3c3..bc93449f 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -125,7 +125,7 @@ createInterface tm flags modMap instIfaceMap = do $ map getName instances ++ map getName fam_instances -- Locations of all TH splices - splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] + splices = [ l | L l (SpliceD _ _) <- hsmodDecls hsm ] warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) @@ -406,9 +406,9 @@ mkMaps dflags gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] names :: SrcSpan -> HsDecl GhcRn -> [Name] - names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of - TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs + TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only for TFs _ -> getInstLoc d names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2]. names _ decl = getMainDeclBinder decl @@ -433,16 +433,16 @@ subordinates :: InstMap -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of - InstD (ClsInstD d) -> do + InstD _ (ClsInstD _ d) -> do DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }}} <- unLoc <$> cid_datafam_insts d [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = d }))) + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d }))) -> dataSubs (feqn_rhs d) - TyClD d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) + TyClD _ d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d) | (L _ d, doc) <- classDecls dd @@ -456,7 +456,7 @@ subordinates instMap decl = case decl of | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map getConArgs cons - , L _ (ConDeclField ns _ doc) <- (unLoc flds) + , L _ (ConDeclField _ ns _ doc) <- (unLoc flds) , L _ n <- ns ] derivs = [ (instName, [unL doc], M.empty) | HsIB { hsib_body = L l (HsDocTy _ _ doc) } @@ -481,11 +481,11 @@ conArgDocs con = case getConArgs con of -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString -declTypeDocs (SigD (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) -declTypeDocs (SigD (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (SigD (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (ForD (ForeignImport _ ty _ _)) = typeDocs (unLoc (hsSigType ty)) -declTypeDocs (TyClD (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) +declTypeDocs (SigD _ (TypeSig _ _ ty)) = typeDocs (unLoc (hsSigWcType ty)) +declTypeDocs (SigD _ (ClassOpSig _ _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (SigD _ (PatSynSig _ _ ty)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (ForD _ (ForeignImport _ _ ty _)) = typeDocs (unLoc (hsSigType ty)) +declTypeDocs (TyClD _ (SynDecl { tcdRhs = ty })) = typeDocs (unLoc ty) declTypeDocs _ = M.empty -- | Extract function argument docs from inside types. @@ -505,10 +505,10 @@ classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs DocD class_ - defs = mkDecls (bagToList . tcdMeths) ValD class_ - sigs = mkDecls tcdSigs SigD class_ - ats = mkDecls tcdATs (TyClD . FamDecl) class_ + docs = mkDecls tcdDocs (DocD noExt) class_ + defs = mkDecls (bagToList . tcdMeths) (ValD noExt) class_ + sigs = mkDecls tcdSigs (SigD noExt) class_ + ats = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_ -- | The top-level declarations of a module that we care about, @@ -526,14 +526,14 @@ mkFixMap group_ = M.fromList [ (n,f) -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ - mkDecls hs_derivds DerivD group_ ++ - mkDecls hs_defds DefD group_ ++ - mkDecls hs_fords ForD group_ ++ - mkDecls hs_docs DocD group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) InstD group_ ++ - mkDecls (typesigs . hs_valds) SigD group_ ++ - mkDecls (valbinds . hs_valds) ValD group_ + mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt) group_ ++ + mkDecls hs_derivds (DerivD noExt) group_ ++ + mkDecls hs_defds (DefD noExt) group_ ++ + mkDecls hs_fords (ForD noExt) group_ ++ + mkDecls hs_docs (DocD noExt) group_ ++ + mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt) group_ ++ + mkDecls (typesigs . hs_valds) (SigD noExt) group_ ++ + mkDecls (valbinds . hs_valds) (ValD noExt) group_ where typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs typesigs _ = error "expected ValBindsOut" @@ -564,14 +564,14 @@ sortByLoc = sortBy (comparing getLoc) filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterDecls = filter (isHandled . unL . fst) where - isHandled (ForD (ForeignImport {})) = True + isHandled (ForD _ (ForeignImport {})) = True isHandled (TyClD {}) = True isHandled (InstD {}) = True isHandled (DerivD {}) = True - isHandled (SigD d) = isUserLSig (reL d) - isHandled (ValD _) = True + isHandled (SigD _ d) = isUserLSig (reL d) + isHandled (ValD {}) = True -- we keep doc declarations to be able to get at named docs - isHandled (DocD _) = True + isHandled (DocD {}) = True isHandled _ = False @@ -580,8 +580,8 @@ filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x | x@(L loc d, doc) <- decls ] where - filterClass (TyClD c) = - TyClD $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } + filterClass (TyClD x c) = + TyClD x $ c { tcdSigs = filter (liftA2 (||) isUserLSig isMinimalLSig) $ tcdSigs c } filterClass _ = error "expected TyClD" @@ -600,10 +600,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs (L _ (DocD (DocCommentNext str)) : ds) + go prev docs (L _ (DocD _ (DocCommentNext str)) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds + go prev docs (L _ (DocD _ (DocCommentPrev str)) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -644,22 +644,22 @@ mkExportItems decls maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do + lookupExport (IEGroup _ lev docStr, _) = liftErrMsg $ do doc <- processDocString dflags gre docStr return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr, _) = liftErrMsg $ do + lookupExport (IEDoc _ docStr, _) = liftErrMsg $ do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEDocNamed str, _) = liftErrMsg $ + lookupExport (IEDocNamed _ str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEModuleContents (L _ mod_name), _) + lookupExport (IEModuleContents _ (L _ mod_name), _) -- only consider exporting a module if we are sure we -- are really exporting the whole module and not some -- subset. We also look through module aliases here. @@ -696,7 +696,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames let t = availName avail r <- findDecl avail case r of - ([L l (ValD _)], (doc, _)) -> do + ([L l (ValD _ _)], (doc, _)) -> do -- Top-level binding without type signature export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap return [export] @@ -721,17 +721,17 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames -- A single signature might refer to many names, but we -- create an export item for a single name only. So we -- modify the signature to contain only that single name. - L loc (SigD sig) -> + L loc (SigD _ sig) -> -- 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 + let newDecl = L loc . SigD noExt . fromJust $ filterSigNames (== t) sig in availExportDecl avail newDecl docs_ - L loc (TyClD cl@ClassDecl{}) -> do + L loc (TyClD _ cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig noExt NoSourceText . noLoc . fmap noLoc) mdef availExportDecl avail - (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ + (L loc $ TyClD noExt cl { tcdSigs = sig ++ tcdSigs cl }) docs_ _ -> availExportDecl avail decl docs_ @@ -994,7 +994,7 @@ fullModuleContents is_sig modMap thisMod semMod warnings exportedNames for (getMainDeclBinder (unLoc decl)) $ \nm -> do case lookupNameEnv availEnv nm of Just avail - | L _ (ValD valDecl) <- decl + | L _ (ValD _ valDecl) <- decl , (name:_) <- collectHsBindBinders valDecl , Just (L _ SigD{}:_) <- filter isSigD <$> M.lookup name declMap -> pure [] @@ -1017,7 +1017,7 @@ extractDecl declMap name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of - TyClD d@ClassDecl {} -> + TyClD _ d@ClassDecl {} -> let matchesMethod = [ lsig @@ -1037,8 +1037,8 @@ extractDecl declMap name decl in case (matchesMethod, matchesAssociatedType) of ([s0], _) -> let (n, tyvar_names) = (tcdName d, tyClDeclTyVars d) L pos sig = addClassContext n tyvar_names s0 - in L pos (SigD sig) - (_, [L pos fam_decl]) -> L pos (TyClD (FamDecl fam_decl)) + in L pos (SigD noExt sig) + (_, [L pos fam_decl]) -> L pos (TyClD noExt (FamDecl noExt fam_decl)) ([], []) | Just (famInstDecl:_) <- M.lookup name declMap @@ -1047,21 +1047,21 @@ extractDecl declMap name decl O.$$ O.nest 4 (O.ppr d) O.$$ O.text "Matches:" O.$$ O.nest 4 (O.ppr matchesMethod O.<+> O.ppr matchesAssociatedType)) - TyClD d@DataDecl {} -> + TyClD _ d@DataDecl {} -> let (n, tyvar_tys) = (tcdName d, lHsQTyVarsToTypes (tyClDeclTyVars 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)) - TyClD FamDecl {} + then SigD noExt <$> extractPatternSyn name n tyvar_tys (dd_cons (tcdDataDefn d)) + else SigD noExt <$> extractRecSel name n tyvar_tys (dd_cons (tcdDataDefn d)) + TyClD _ FamDecl {} | isValName name , Just (famInst:_) <- M.lookup name declMap -> extractDecl declMap name famInst - InstD (DataFamInstD (DataFamInstDecl (HsIB { hsib_body = + InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = FamEqn { feqn_tycon = L _ n , feqn_pats = tys , feqn_rhs = defn }}))) -> - SigD <$> extractRecSel name n tys (dd_cons defn) - InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> + SigD noExt <$> extractRecSel name n tys (dd_cons defn) + InstD _ (ClsInstD _ ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d' | L _ d'@(DataFamInstDecl (HsIB { hsib_body = d })) <- insts -- , L _ ConDecl { con_details = RecCon rec } <- dd_cons (feqn_rhs d) @@ -1071,7 +1071,7 @@ extractDecl declMap name decl , extFieldOcc n == name ] in case matches of - [d0] -> extractDecl declMap name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl declMap name (noLoc . InstD noExt $ DataFamInstD noExt d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" @@ -1112,12 +1112,12 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = case getConArgs con of - RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields -> + RecCon (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> L l (TypeSig noExt [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] - matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds + matching_fields flds = [ (l,f) | f@(L _ (ConDeclField _ ns _ _)) <- flds , L l n <- ns, extFieldOcc n == nm ] data_ty -- ResTyGADT _ ty <- con_res con = ty @@ -1142,8 +1142,8 @@ mkVisibleNames (_, _, _, instMap) exports opts 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 + InstD _ d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. exportName _ = [] @@ -1184,7 +1184,7 @@ findNamedDoc name = search search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search (DocD (DocCommentNamed name' doc) : rest) + search (DocD _ (DocCommentNamed name' doc) : rest) | name == name' = return (Just doc) | otherwise = search rest search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 0652ae47..5b588964 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -21,6 +21,7 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name +import Outputable ( panic ) import Control.Applicative import Control.Monad hiding (mapM) @@ -188,14 +189,15 @@ renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) -renameFamilyResultSig (L loc NoSig) - = return (L loc NoSig) -renameFamilyResultSig (L loc (KindSig ki)) +renameFamilyResultSig (L loc (NoSig _)) + = return (L loc (NoSig noExt)) +renameFamilyResultSig (L loc (KindSig _ ki)) = do { ki' <- renameLKind ki - ; return (L loc (KindSig ki')) } -renameFamilyResultSig (L loc (TyVarSig bndr)) + ; return (L loc (KindSig noExt ki')) } +renameFamilyResultSig (L loc (TyVarSig _ bndr)) = do { bndr' <- renameLTyVarBndr bndr - ; return (L loc (TyVarSig bndr')) } + ; return (L loc (TyVarSig noExt bndr')) } +renameFamilyResultSig (L _ (XFamilyResultSig _)) = panic "haddock:renameFamilyResultSig" renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) @@ -212,55 +214,55 @@ renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_xforall = NoExt, hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = NoExt, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar NoExt ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy NoExt b =<< renameLType ltype HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy PlaceHolder a' b') + return (HsAppTy NoExt a' b') HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy PlaceHolder a' b') + return (HsFunTy NoExt a' b') - HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty - HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty - HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty) - HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2) + HsListTy _ ty -> return . (HsListTy NoExt) =<< renameLType ty + HsPArrTy _ ty -> return . (HsPArrTy NoExt) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy NoExt n) (renameLType ty) + HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy NoExt) (renameLType ty1) (renameLType ty2) - HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy NoExt b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy NoExt <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy PlaceHolder a' (L loc op') b') + return (HsOpTy NoExt a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy NoExt) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig PlaceHolder ty' k') + return (HsKindSig NoExt ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy PlaceHolder ty' doc') + return (HsDocTy NoExt ty' doc') - HsTyLit _ x -> return (HsTyLit PlaceHolder x) + HsTyLit _ x -> return (HsTyLit NoExt x) - HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a + HsRecTy _ a -> HsRecTy NoExt <$> mapM renameConDeclFieldField a (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a)) HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b @@ -269,10 +271,11 @@ renameType t = case t of HsAppsTy _ _ -> error "renameType: HsAppsTy" renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) -renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) +renameLHsQTyVars (HsQTvs { hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs - ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } - -- This is rather bogus, but I'm not sure what else to do + ; return (HsQTvs { hsq_ext = noExt + , hsq_explicit = tvs' }) } +renameLHsQTyVars (XLHsQTyVars _) = panic "haddock:renameLHsQTyVars" renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar x (L l n))) @@ -289,8 +292,8 @@ renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) -renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo :: HsWildCardInfo -> RnM HsWildCardInfo +renameWildCardInfo (AnonWildCard (L l name)) = return (AnonWildCard (L l name)) renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do @@ -321,21 +324,21 @@ renamePats = mapM renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of - TyClD d -> do + TyClD _ d -> do d' <- renameTyClD d - return (TyClD d') - SigD s -> do + return (TyClD noExt d') + SigD _ s -> do s' <- renameSig s - return (SigD s') - ForD d -> do + return (SigD noExt s') + ForD _ d -> do d' <- renameForD d - return (ForD d') - InstD d -> do + return (ForD noExt d') + InstD _ d -> do d' <- renameInstD d - return (InstD d') - DerivD d -> do + return (InstD noExt d') + DerivD _ d -> do d' <- renameDerivD d - return (DerivD d') + return (DerivD noExt d') _ -> error "renameDecl" renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) @@ -346,19 +349,21 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl - return (FamDecl { tcdFam = decl' }) + return (FamDecl { tcdFExt = noExt, tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do + SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars rhs' <- renameLType rhs - return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames }) + return (SynDecl { tcdSExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdRhs = rhs' }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do + DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn } -> do lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) + return (DataDecl { tcdDExt = noExt, tcdLName = lname', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -373,7 +378,8 @@ renameTyClD d = case d of return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFixity = fixity , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag - , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = NoExt }) + XTyClDecl _ -> panic "haddock:renameTyClD" where renameLFunDep (L loc (xs, ys)) = do @@ -394,11 +400,12 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname ltyvars' <- renameLHsQTyVars ltyvars result' <- renameFamilyResultSig result injectivity' <- renameMaybeInjectivityAnn injectivity - return (FamilyDecl { fdInfo = info', fdLName = lname' + return (FamilyDecl { fdExt = noExt, fdInfo = info', fdLName = lname' , fdTyVars = ltyvars' , fdFixity = fixity , fdResultSig = result' , fdInjectivityAnn = injectivity' }) +renameFamilyDecl (XFamilyDecl _) = panic "renameFamilyDecl" renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn @@ -424,9 +431,11 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType k' <- renameMaybeLKind k cons' <- mapM (mapM renameCon) cons -- I don't think we need the derivings, so we return Nothing - return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType + return (HsDataDefn { dd_ext = noExt + , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) +renameDataDefn (XHsDataDefn _) = panic "haddock:renameDataDefn" renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -437,7 +446,7 @@ renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars lcontext' <- traverse renameLContext lcontext details' <- renameDetails details mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_name = lname', con_ex_tvs = ltyvars' + return (decl { con_ext = noExt, con_name = lname', con_ex_tvs = ltyvars' , con_mb_cxt = lcontext' , con_args = details', con_doc = mbldoc' }) @@ -451,9 +460,10 @@ renameCon decl@(ConDeclGADT { con_names = lnames, con_qvars = ltyvars details' <- renameDetails details res_ty' <- renameLType res_ty mbldoc' <- mapM renameLDocHsSyn mbldoc - return (decl { con_names = lnames', con_qvars = ltyvars' + return (decl { con_g_ext = noExt, con_names = lnames', con_qvars = ltyvars' , con_mb_cxt = lcontext', con_args = details' , con_res_ty = res_ty', con_doc = mbldoc' }) +renameCon (XConDecl _) = panic "haddock:renameCon" renameDetails :: HsConDeclDetails GhcRn -> RnM (HsConDeclDetails DocNameI) renameDetails (RecCon (L l fields)) = do @@ -466,11 +476,12 @@ renameDetails (InfixCon a b) = do return (InfixCon a' b') renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) -renameConDeclFieldField (L l (ConDeclField names t doc)) = do +renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc - return $ L l (ConDeclField names' t' doc') + return $ L l (ConDeclField noExt names' t' doc') +renameConDeclFieldField (L _ (XConDeclField _)) = panic "haddock:renameConDeclFieldField" renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -503,35 +514,39 @@ renameSig sig = case sig of renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) -renameForD (ForeignImport lname ltype co x) = do +renameForD (ForeignImport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignImport lname' ltype' co x) -renameForD (ForeignExport lname ltype co x) = do + return (ForeignImport noExt lname' ltype' x) +renameForD (ForeignExport _ lname ltype x) = do lname' <- renameL lname ltype' <- renameLSigType ltype - return (ForeignExport lname' ltype' co x) + return (ForeignExport noExt lname' ltype' x) +renameForD (XForeignDecl _) = panic "haddock:renameForD" renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d - return (ClsInstD { cid_inst = d' }) + return (ClsInstD { cid_d_ext = noExt, cid_inst = d' }) renameInstD (TyFamInstD { tfid_inst = d }) = do d' <- renameTyFamInstD d - return (TyFamInstD { tfid_inst = d' }) + return (TyFamInstD { tfid_ext = noExt, tfid_inst = d' }) renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d - return (DataFamInstD { dfid_inst = d' }) + return (DataFamInstD { dfid_ext = noExt, dfid_inst = d' }) +renameInstD (XInstDecl _) = panic "haddock:renameInstD" renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do ty' <- renameLSigWcType ty - return (DerivDecl { deriv_type = ty' + return (DerivDecl { deriv_ext = noExt + , deriv_type = ty' , deriv_strategy = strat , deriv_overlap_mode = omode }) +renameDerivD (XDerivDecl _) = panic "haddock:renameDerivD" renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode @@ -540,10 +555,11 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode ltype' <- renameLSigType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs - return (ClsInstDecl { cid_overlap_mode = omode + return (ClsInstDecl { cid_ext = noExt, cid_overlap_mode = omode , cid_poly_ty = ltype', cid_binds = emptyBag , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) +renameClsInstD (XClsInstDecl _) = panic "haddock:renameClsInstD" renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) @@ -563,10 +579,12 @@ renameTyFamInstEqn eqn = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; rhs' <- renameLType rhs - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = rhs' }) } + rename_ty_fam_eqn (XFamEqn _) = panic "haddock:renameTyFamInstEqn" renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs @@ -574,10 +592,12 @@ renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs ; rhs' <- renameLType rhs - ; return (L loc (FamEqn { feqn_tycon = tc' + ; return (L loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = tvs' , feqn_fixity = fixity , feqn_rhs = rhs' })) } +renameLTyFamDefltEqn (L _ (XFamEqn _)) = panic "haddock:renameLTyFamDefltEqn" renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) @@ -592,10 +612,12 @@ renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType pats ; defn' <- renameDataDefn defn - ; return (FamEqn { feqn_tycon = tc' + ; return (FamEqn { feqn_ext = noExt + , feqn_tycon = tc' , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = defn' }) } + rename_data_fam_eqn (XFamEqn _) = panic "haddock:renameDataFamInstD" renameImplicit :: (in_thing -> RnM out_thing) -> HsImplicitBndrs GhcRn in_thing @@ -603,8 +625,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder }) } + , hsib_ext = noExt }) } +renameImplicit _ (XHsImplicitBndrs _) = panic "haddock:renameImplicit" renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -612,7 +634,8 @@ renameWc :: (in_thing -> RnM out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder }) } + , hswc_ext = noExt }) } +renameWc _ (XHsWildCardBndrs _) = panic "haddock:renameWc" renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index b84a676f..c49663db 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -110,7 +110,7 @@ sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp + | isBuiltInSyntax name' && strName == "[]" = HsListTy NoExt ltyp where name' = getName name strName = occNameString . nameOccName $ name' @@ -124,7 +124,7 @@ sugarTuples typ = aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp aux apps (HsParTy _ (L _ typ')) = aux apps typ' aux apps (HsTyVar _ _ (L _ name)) - | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps + | isBuiltInSyntax name' && suitable = HsTupleTy NoExt HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -137,7 +137,7 @@ sugarTuples typ = sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb) | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb - | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy NoExt la lb where name' = getName name sugarOperators typ = typ diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 2234894c..99fccf2a 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -381,11 +381,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl } where mkType (KindedTyVar _ (L loc name) lkind) = - HsKindSig PlaceHolder tvar lkind + HsKindSig NoExt tvar lkind where - tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name)) - mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name + tvar = L loc (HsTyVar NoExt NotPromoted (L loc name)) + mkType (UserTyVar _ name) = HsTyVar NoExt NotPromoted name mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" +mkPseudoFamilyDecl (XFamilyDecl {}) = panic "haddock:mkPseudoFamilyDecl" -- | An instance head that may have documentation and a source location. @@ -652,54 +653,77 @@ instance Monad ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocNameI NameSet = PlaceHolder -type instance PostRn DocNameI Fixity = PlaceHolder -type instance PostRn DocNameI Bool = PlaceHolder -type instance PostRn DocNameI Name = DocName -type instance PostRn DocNameI (Located Name) = Located DocName -type instance PostRn DocNameI [Name] = PlaceHolder -type instance PostRn DocNameI DocName = DocName - -type instance PostTc DocNameI Kind = PlaceHolder -type instance PostTc DocNameI Type = PlaceHolder -type instance PostTc DocNameI Coercion = PlaceHolder - - -type instance XForAllTy DocNameI = PlaceHolder -type instance XQualTy DocNameI = PlaceHolder -type instance XTyVar DocNameI = PlaceHolder -type instance XAppsTy DocNameI = PlaceHolder -type instance XAppTy DocNameI = PlaceHolder -type instance XFunTy DocNameI = PlaceHolder -type instance XListTy DocNameI = PlaceHolder -type instance XPArrTy DocNameI = PlaceHolder -type instance XTupleTy DocNameI = PlaceHolder -type instance XSumTy DocNameI = PlaceHolder -type instance XOpTy DocNameI = PlaceHolder -type instance XParTy DocNameI = PlaceHolder -type instance XIParamTy DocNameI = PlaceHolder -type instance XEqTy DocNameI = PlaceHolder -type instance XKindSig DocNameI = PlaceHolder -type instance XSpliceTy DocNameI = PlaceHolder -type instance XDocTy DocNameI = PlaceHolder -type instance XBangTy DocNameI = PlaceHolder -type instance XRecTy DocNameI = PlaceHolder -type instance XExplicitListTy DocNameI = PlaceHolder -type instance XExplicitTupleTy DocNameI = PlaceHolder -type instance XTyLit DocNameI = PlaceHolder -type instance XWildCardTy DocNameI = HsWildCardInfo DocNameI +type instance XForAllTy DocNameI = NoExt +type instance XQualTy DocNameI = NoExt +type instance XTyVar DocNameI = NoExt +type instance XAppsTy DocNameI = NoExt +type instance XAppTy DocNameI = NoExt +type instance XFunTy DocNameI = NoExt +type instance XListTy DocNameI = NoExt +type instance XPArrTy DocNameI = NoExt +type instance XTupleTy DocNameI = NoExt +type instance XSumTy DocNameI = NoExt +type instance XOpTy DocNameI = NoExt +type instance XParTy DocNameI = NoExt +type instance XIParamTy DocNameI = NoExt +type instance XEqTy DocNameI = NoExt +type instance XKindSig DocNameI = NoExt +type instance XSpliceTy DocNameI = NoExt +type instance XDocTy DocNameI = NoExt +type instance XBangTy DocNameI = NoExt +type instance XRecTy DocNameI = NoExt +type instance XExplicitListTy DocNameI = NoExt +type instance XExplicitTupleTy DocNameI = NoExt +type instance XTyLit DocNameI = NoExt +type instance XWildCardTy DocNameI = HsWildCardInfo type instance XXType DocNameI = NewHsTypeX -type instance XUserTyVar DocNameI = PlaceHolder -type instance XKindedTyVar DocNameI = PlaceHolder -type instance XXTyVarBndr DocNameI = PlaceHolder +type instance XUserTyVar DocNameI = NoExt +type instance XKindedTyVar DocNameI = NoExt +type instance XXTyVarBndr DocNameI = NoExt type instance XFieldOcc DocNameI = DocName -type instance XXFieldOcc DocNameI = PlaceHolder - -type instance XFixitySig DocNameI = PlaceHolder -type instance XFixSig DocNameI = PlaceHolder -type instance XPatSynSig DocNameI = PlaceHolder -type instance XClassOpSig DocNameI = PlaceHolder -type instance XTypeSig DocNameI = PlaceHolder -type instance XMinimalSig DocNameI = PlaceHolder +type instance XXFieldOcc DocNameI = NoExt + +type instance XFixitySig DocNameI = NoExt +type instance XFixSig DocNameI = NoExt +type instance XPatSynSig DocNameI = NoExt +type instance XClassOpSig DocNameI = NoExt +type instance XTypeSig DocNameI = NoExt +type instance XMinimalSig DocNameI = NoExt + +type instance XForeignExport DocNameI = NoExt +type instance XForeignImport DocNameI = NoExt +type instance XConDeclGADT DocNameI = NoExt +type instance XConDeclH98 DocNameI = NoExt + +type instance XDerivD DocNameI = NoExt +type instance XInstD DocNameI = NoExt +type instance XForD DocNameI = NoExt +type instance XSigD DocNameI = NoExt +type instance XTyClD DocNameI = NoExt + +type instance XNoSig DocNameI = NoExt +type instance XCKindSig DocNameI = NoExt +type instance XTyVarSig DocNameI = NoExt + +type instance XCFamEqn DocNameI _ _ = NoExt + +type instance XCClsInstDecl DocNameI = NoExt +type instance XCDerivDecl DocNameI = NoExt +type instance XDataFamInstD DocNameI = NoExt +type instance XTyFamInstD DocNameI = NoExt +type instance XClsInstD DocNameI = NoExt +type instance XCHsDataDefn DocNameI = NoExt +type instance XCFamilyDecl DocNameI = NoExt +type instance XClassDecl DocNameI = NoExt +type instance XDataDecl DocNameI = NoExt +type instance XSynDecl DocNameI = NoExt +type instance XFamDecl DocNameI = NoExt + +type instance XHsIB DocNameI _ = NoExt +type instance XHsWC DocNameI _ = NoExt + +type instance XHsQTvs DocNameI = NoExt +type instance XConDeclField DocNameI = NoExt + diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 1ebf7ffa..e3cc9655 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -64,6 +64,7 @@ import GHC import Name import NameSet ( emptyNameSet ) import HsTypes (extFieldOcc) +import Outputable ( panic ) import Control.Monad ( liftM ) import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) @@ -152,7 +153,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar NoExt NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- @@ -162,10 +163,10 @@ lHsQTyVarsToTypes tvs restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d -> - TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) - TyClD d | isClassDecl d -> - TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), + TyClD x d | isDataDecl d -> + TyClD x (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD x d | isClassDecl d -> + TyClD x (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl @@ -178,6 +179,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [] -> defn { dd_ND = DataType, dd_cons = [] } [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" +restrictDataDefn _ (XHsDataDefn _) = error "restrictDataDefn" restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] @@ -195,9 +197,10 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] InfixCon _ _ -> Just d where field_avail :: LConDeclField GhcRn -> Bool - field_avail (L _ (ConDeclField fs _ _)) + field_avail (L _ (ConDeclField _ fs _ _)) = all (\f -> extFieldOcc (unLoc f) `elem` names) fs - field_types flds = [ t | ConDeclField _ t _ <- flds ] + field_avail (L _ (XConDeclField _)) = panic "haddock:field_avail" + field_types flds = [ t | ConDeclField _ _ t _ <- flds ] keep _ = Nothing @@ -208,13 +211,14 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] -emptyHsQTvs :: LHsQTyVars Name +emptyHsQTvs :: LHsQTyVars GhcRn -- This function is here, rather than in HsTypes, because it *renamed*, but -- does not necessarily have all the rigt kind variables. It is used -- in Haddock just for printing, so it doesn't matter -emptyHsQTvs = HsQTvs { hsq_implicit = error "haddock:emptyHsQTvs" - , hsq_explicit = [] - , hsq_dependent = error "haddock:emptyHsQTvs" } +emptyHsQTvs = HsQTvs { hsq_ext = HsQTvsRn + { hsq_implicit = error "haddock:emptyHsQTvs" + , hsq_dependent = error "haddock:emptyHsQTvs" } + , hsq_explicit = [] } -------------------------------------------------------------------------------- -- cgit v1.2.3