diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2020-04-18 18:37:38 +0100 | 
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2021-03-15 17:15:26 +0000 | 
| commit | 6173eeaa1608a4325ecd005feec05d3ab4e9323f (patch) | |
| tree | bb95cc5f7bd8ec026df1e94e989ffed83a548ab5 /haddock-api | |
| parent | d930bd87cd43d840bf2877e4a51b2a48c2e18f74 (diff) | |
Match changes in GHC AST for in-tree API Annotations
As landed via https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2418
Diffstat (limited to 'haddock-api')
| -rw-r--r-- | haddock-api/haddock-api.cabal | 1 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hoogle.hs | 38 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/LaTeX.hs | 33 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml.hs | 3 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 78 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Layout.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Names.hs | 5 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Convert.hs | 187 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/GhcUtils.hs | 84 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface.hs | 2 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/AttachInstances.hs | 7 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Create.hs | 41 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Rename.hs | 106 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Interface/Specialize.hs | 26 | ||||
| -rw-r--r-- | haddock-api/src/Haddock/Types.hs | 106 | 
17 files changed, 387 insertions, 336 deletions
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal index e9433d73..730f4f5c 100644 --- a/haddock-api/haddock-api.cabal +++ b/haddock-api/haddock-api.cabal @@ -194,6 +194,7 @@ test-suite spec                 , exceptions                 , filepath                 , ghc-boot +               , ghc-boot-th                 , transformers    build-tool-depends: diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 1a0cccf7..e70a705f 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -72,7 +72,7 @@ ppModule dflags unit_state iface =  ---------------------------------------------------------------------  -- Utility functions -dropHsDocTy :: HsSigType (GhcPass p) -> HsSigType (GhcPass p) +dropHsDocTy :: HsSigType GhcRn -> HsSigType GhcRn  dropHsDocTy = drop_sig_ty      where          drop_sig_ty (HsSig x a b)  = HsSig x a (drop_lty b) @@ -94,8 +94,7 @@ dropHsDocTy = drop_sig_ty          drop_ty (HsDocTy _ a _) = drop_ty $ unL a          drop_ty x = x -outHsSigType :: (OutputableBndrId p, NoGhcTcPass p ~ p) -             => DynFlags -> HsSigType (GhcPass p) -> String +outHsSigType :: DynFlags -> HsSigType GhcRn -> String  outHsSigType dflags = out dflags . reparenSigType . dropHsDocTy @@ -154,13 +153,13 @@ ppSigWithDoc dflags sig subdocs = case sig of      PatSynSig _ names t -> concatMap (mkDocSig "pattern " t) names      _ -> []    where -    mkDocSig leader typ n = mkSubdoc dflags n subdocs -                                     [leader ++ pp_sig dflags [n] typ] +    mkDocSig leader typ n = mkSubdocN dflags n subdocs +                                      [leader ++ pp_sig dflags [n] typ]  ppSig :: DynFlags -> Sig GhcRn -> [String]  ppSig dflags x  = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsSigType GhcRn -> String +pp_sig :: DynFlags -> [LocatedN Name] -> LHsSigType GhcRn -> String  pp_sig dflags names (L _ typ)  =      operator prettyNames ++ " :: " ++ outHsSigType dflags typ      where @@ -187,7 +186,7 @@ ppClass dflags decl subdocs =          pprTyFam :: LFamilyDecl GhcRn -> SDoc          pprTyFam (L _ at) = vcat' $ map text $ -            mkSubdoc dflags (fdLName at) subdocs (ppFam dflags at) +            mkSubdocN dflags (fdLName at) subdocs (ppFam dflags at)          whereWrapper elems = vcat'              [ text "where" <+> lbrace @@ -222,7 +221,7 @@ ppSynonym dflags x = [out dflags x]  ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]  ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs -    = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : +    = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=[] }} :        concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)      where @@ -235,7 +234,7 @@ ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs  ppData _ _ _ = panic "ppData"  -- | for constructors, and named-fields... -lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> LocatedN Name -> [String]  lookupCon dflags subdocs (L _ name) = case lookup name subdocs of    Just (d, _) -> ppDocumentation dflags d    _ -> [] @@ -248,11 +247,11 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }          f (PrefixCon _ args) = [typeSig name $ (map hsScaledThing args) ++ [resType]]          f (InfixCon a1 a2) = f $ PrefixCon [] [a1,a2]          f (RecCon (L _ recs)) = f (PrefixCon [] $ map (hsLinear . cd_fld_type . unLoc) recs) ++ concat -                          [(concatMap (lookupCon dflags subdocs . noLoc . extFieldOcc . unLoc) (cd_fld_names r)) ++ +                          [(concatMap (lookupCon dflags subdocs . noLocA . 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 noExtField (HsUnrestrictedArrow NormalSyntax) x y) +        funs = foldr1 (\x y -> reL $ HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)          apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)          typeSig nm flds = operator nm ++ " :: " ++ @@ -262,12 +261,12 @@ ppCtor dflags dat subdocs con@ConDeclH98 { con_args = con_args' }          -- docs for con_names on why it is a list to begin with.          name = commaSeparate dflags . map unL $ getConNames con -        tyVarArg (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n -        tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) lty +        tyVarArg (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n +        tyVarArg (KindedTyVar _ _ n lty) = HsKindSig noAnn (reL (HsTyVar noAnn NotPromoted n)) lty          tyVarArg _ = panic "ppCtor"          resType = apps $ map reL $ -                        (HsTyVar noExtField NotPromoted (reL (tcdName dat))) : +                        (HsTyVar noAnn NotPromoted (reL (tcdName dat))) :                          map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)  ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names @@ -281,15 +280,15 @@ ppCtor dflags _dat subdocs (ConDeclGADT { con_names = names          name = out dflags $ map unL names          con_sig_ty = HsSig noExtField outer_bndrs theta_ty where            theta_ty = case mcxt of -            Just theta -> noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) +            Just theta -> noLocA (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty })              Nothing -> tau_ty            tau_ty = foldr mkFunTy res_ty $              case args of PrefixConGADT pos_args -> map hsScaledThing pos_args                           RecConGADT (L _ flds) -> map (cd_fld_type . unL) flds -          mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) +          mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)  ppFixity :: DynFlags -> (Name, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLoc name] fixity) :: FixitySig GhcRn)] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig noExtField [noLocA name] fixity) :: FixitySig GhcRn)]  --------------------------------------------------------------------- @@ -312,7 +311,10 @@ docWith dflags header d      lines header ++ ["" | header /= "" && isJust d] ++      maybe [] (showTags . markup (markupTag dflags)) d -mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN :: DynFlags -> LocatedN Name -> [(Name, DocForDecl Name)] -> [String] -> [String] +mkSubdocN dflags n subdocs s = mkSubdoc dflags (n2l n) subdocs s + +mkSubdoc :: DynFlags -> LocatedA Name -> [(Name, DocForDecl Name)] -> [String] -> [String]  mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s   where     getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs index 2def35ae..d9a2e0cd 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs @@ -360,7 +360,7 @@ classify tok =      -- the GHC lexer for more), so we have to manually reverse this. The      -- following is a hammer: it smashes _all_ pragma-like block comments into      -- pragmas. -    ITblockComment c +    ITblockComment c _        | isPrefixOf "{-#" c        , isSuffixOf "#-}" c -> TkPragma        | otherwise          -> TkComment diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index e2e16947..abf882f0 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -390,10 +390,11 @@ ppFamHeader (FamilyDecl { fdLName = L _ name      injAnn = case injectivity of        Nothing -> empty -      Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( decltt (text "|") -                                                  : ppLDocName lhs -                                                  : arrow unicode -                                                  : map ppLDocName rhs) +      Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( decltt (text "|") +                                                    : ppLDocName lhs +                                                    : arrow unicode +                                                    : map ppLDocName rhs) +      Just _ -> empty @@ -597,8 +598,8 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace  ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName -           -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName +           -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]             -> Bool -> LaTeX  ppClassHdr summ lctxt n tvs fds unicode =    keyword "class" @@ -606,14 +607,16 @@ ppClassHdr summ lctxt n tvs fds unicode =    <+> ppAppDocNameNames summ n (tyvarNames tvs)    <+> ppFds fds unicode - -ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX +-- ppFds :: [Located ([LocatedA DocName], [LocatedA DocName])] -> Bool -> LaTeX +ppFds :: [LHsFunDep DocNameI] -> Bool -> LaTeX  ppFds fds unicode =    if null fds then empty else      char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))    where -    fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+> +    fundep (FunDep _ vars1 vars2) +                         = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>                             hsep (map (ppDocName . unLoc) vars2) +    fundep (XFunDep _) = error "ppFds"  -- TODO: associated type defaults, docs on default methods @@ -804,7 +807,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) =      decl = case con of        ConDeclH98{ con_args = det                  , con_ex_tvs = tyVars -                , con_forall = L _ forall_ +                , con_forall = forall_                  , con_mb_cxt = cxt                  } -> let context = fromMaybeContext cxt                           header_ = ppConstrHdr forall_ tyVars context unicode @@ -893,7 +896,7 @@ ppSideBySideField subdocs unicode (ConDeclField _ names ltype _) =  -- | Pretty-print a bundled pattern synonym -ppSideBySidePat :: [Located DocName]    -- ^ pattern name(s) +ppSideBySidePat :: [LocatedN DocName]   -- ^ pattern name(s)                  -> LHsSigType DocNameI  -- ^ type of pattern(s)                  -> DocForDecl DocName   -- ^ doc map                  -> Bool                 -- ^ unicode @@ -1036,7 +1039,7 @@ sumParens = ubxparens . hsep . punctuate (text " |")  -- Stolen from Html and tweaked for LaTeX generation  ------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocNameI) -> LaTeX +ppLType, ppLParendType, ppLFunLhType :: Bool -> LHsType DocNameI -> LaTeX  ppLType       unicode y = ppType unicode (unLoc y)  ppLParendType unicode y = ppParendType unicode (unLoc y)  ppLFunLhType  unicode y = ppFunLhType unicode (unLoc y) @@ -1104,9 +1107,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2)   u    = sep [ ppr_mono_lty ty1 u          , arr <+> ppr_mono_lty ty2 u ]     where arr = case mult of -                 HsLinearArrow _ -> lollipop u +                 HsLinearArrow _ _ -> lollipop u                   HsUnrestrictedArrow _ -> arrow u -                 HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u +                 HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u <+> arrow u  ppr_mono_ty (HsBangTy _ b ty)     u = ppBang b <> ppLParendType u ty  ppr_mono_ty (HsTyVar _ NotPromoted (L _ name)) _ = ppDocName name @@ -1187,7 +1190,7 @@ ppOccName = text . occNameString  ppDocName :: DocName -> LaTeX  ppDocName = ppOccName . nameOccName . getName -ppLDocName :: Located DocName -> LaTeX +ppLDocName :: GenLocated l DocName -> LaTeX  ppLDocName (L _ d) = ppDocName d diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index 1bdbf81b..d390a95a 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -49,8 +49,7 @@ import qualified Data.Map as Map hiding ( Map )  import qualified Data.Set as Set hiding ( Set )  import Data.Ord              ( comparing ) -import GHC.Driver.Session (Language(..)) -import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..) ) +import GHC hiding ( NoLink, moduleInfo,LexicalFixity(..), anchor )  import GHC.Types.Name  import GHC.Unit.State diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index e48f9bdd..8de1b1b8 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -58,22 +58,22 @@ ppDecl :: Bool                                     -- ^ print summary info only         -> Qualification         -> Html  ppDecl summ links (L loc decl) pats (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode pkg qual = case decl of -  TyClD _ (FamDecl _ d)          -> ppFamDecl summ False links instances fixities loc mbDoc d splice unicode pkg qual -  TyClD _ d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs loc mbDoc d pats splice unicode pkg qual -  TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode pkg qual -  TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode pkg qual -  SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames +  TyClD _ (FamDecl _ d)          -> ppFamDecl summ False links instances fixities (locA loc) mbDoc d splice unicode pkg qual +  TyClD _ d@(DataDecl {})        -> ppDataDecl summ links instances fixities subdocs (locA loc) mbDoc d pats splice unicode pkg qual +  TyClD _ d@(SynDecl {})         -> ppTySyn summ links fixities (locA loc) (mbDoc, fnArgsDoc) d splice unicode pkg qual +  TyClD _ d@(ClassDecl {})       -> ppClassDecl summ links instances fixities (locA loc) mbDoc subdocs d splice unicode pkg qual +  SigD _ (TypeSig _ lnames lty)  -> ppLFunSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames                                           (dropWildCards lty) fixities splice unicode pkg qual -  SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links loc (mbDoc, fnArgsDoc) lnames +  SigD _ (PatSynSig _ lnames lty) -> ppLPatSig summ links (locA loc) (mbDoc, fnArgsDoc) lnames                                           lty fixities splice unicode pkg qual -  ForD _ d                       -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual +  ForD _ d                       -> ppFor summ links (locA loc) (mbDoc, fnArgsDoc) d fixities splice unicode pkg qual    InstD _ _                      -> noHtml    DerivD _ _                     -> noHtml    _                              -> error "declaration not supported by ppDecl"  ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> -             [Located DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] -> +             [LocatedN DocName] -> LHsSigType DocNameI -> [(DocName, Fixity)] ->               Splice -> Unicode -> Maybe Package -> Qualification -> Html  ppLFunSig summary links loc doc lnames lty fixities splice unicode pkg qual =    ppFunSig summary links loc noHtml doc (map unLoc lnames) lty fixities @@ -90,7 +90,7 @@ ppFunSig summary links loc leader doc docnames typ fixities splice unicode pkg q  -- | Pretty print a pattern synonym  ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -          -> [Located DocName]     -- ^ names of patterns in declaration +          -> [LocatedN DocName]     -- ^ names of patterns in declaration            -> LHsSigType DocNameI   -- ^ type of patterns in declaration            -> [(DocName, Fixity)]            -> Splice -> Unicode -> Maybe Package -> Qualification -> Html @@ -249,7 +249,7 @@ ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars      sig_type = mkHsImplicitSigTypeI ltype      hdr  = hsep ([keyword "type", ppBinder summary occ]                   ++ ppTyVars unicode qual (hsQTvExplicit ltyvars)) -    full = hdr <+> equals <+> ppPatSigType unicode qual (noLoc sig_type) +    full = hdr <+> equals <+> ppPatSigType unicode qual (noLocA sig_type)      occ  = nameOccName . getName $ name      fixs        | summary   = noHtml @@ -330,7 +330,7 @@ ppPseudoFamDecl links splice                                    , pfdTyVars = tvs                                    , pfdLName = L loc name })                  unicode qual = -    topDeclElem links loc splice [name] leader +    topDeclElem links (locA loc) splice [name] leader    where      leader = hsep [ ppFamilyLeader True info                    , ppAppNameTypes name (map unLoc tvs) unicode qual @@ -361,10 +361,11 @@ ppFamHeader summary associated (FamilyDecl { fdInfo = info      injAnn = case injectivity of        Nothing -> noHtml -      Just (L _ (InjectivityAnn lhs rhs)) -> hsep ( keyword "|" -                                                  : ppLDocName qual Raw lhs -                                                  : arrow unicode -                                                  : map (ppLDocName qual Raw) rhs) +      Just (L _ (InjectivityAnn _ lhs rhs)) -> hsep ( keyword "|" +                                                    : ppLDocName qual Raw lhs +                                                    : arrow unicode +                                                    : map (ppLDocName qual Raw) rhs) +      Just _ -> error "ppFamHeader:XInjectivityAnn"  -- | Print the keywords that begin the family declaration  ppFamilyLeader :: Bool -> FamilyInfo DocNameI -> Html @@ -474,8 +475,8 @@ ppHsContext cxt unicode qual = parenList (map (ppType unicode qual HideEmptyCont  ------------------------------------------------------------------------------- -ppClassHdr :: Bool -> Maybe (Located [LHsType DocNameI]) -> DocName -           -> LHsQTyVars DocNameI -> [Located ([Located DocName], [Located DocName])] +ppClassHdr :: Bool -> Maybe (LocatedC [LHsType DocNameI]) -> DocName +           -> LHsQTyVars DocNameI -> [LHsFunDep DocNameI]             -> Unicode -> Qualification -> Html  ppClassHdr summ lctxt n tvs fds unicode qual =    keyword "class" @@ -484,12 +485,13 @@ ppClassHdr summ lctxt n tvs fds unicode qual =    <+> ppFds fds unicode qual -ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html +ppFds :: [LHsFunDep DocNameI] -> Unicode -> Qualification -> Html  ppFds fds unicode qual =    if null fds then noHtml else          char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds))    where -        fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 +        fundep (FunDep _ vars1 vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2 +        fundep (XFunDep _) = error "ppFds"          ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc)  ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocNameI -> SrcSpan @@ -572,9 +574,9 @@ ppClassDecl summary links instances fixities loc d subdocs      lookupDAT name = Map.lookup (getName name) defaultAssocTys      defaultAssocTys = Map.fromList        [ (getName name, (vs, typ)) -      | L _ (TyFamInstDecl (FamEqn { feqn_rhs = typ -                                   , feqn_tycon = L _ name -                                   , feqn_pats = vs })) <- atsDefs +      | L _ (TyFamInstDecl _ (FamEqn { feqn_rhs = typ +                                     , feqn_tycon = L _ name +                                     , feqn_pats = vs })) <- atsDefs        ]      -- Methods @@ -723,7 +725,7 @@ ppInstanceSigs links splice unicode qual sigs = do          L _ rtyp = dropWildCards typ      -- Instance methods signatures are synified and thus don't have a useful      -- SrcSpan value. Use the methods name location instead. -    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLoc $ head $ lnames) names rtyp +    return $ ppSimpleSig links splice unicode qual HideEmptyContexts (getLocA $ head $ lnames) names rtyp  lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 @@ -828,7 +830,7 @@ ppDataDecl summary links instances fixities subdocs loc doc dataDecl pats        [ ppSideBySideConstr subdocs subfixs unicode pkg qual c        | c <- cons        , let subfixs = filter (\(n,_) -> any (\cn -> cn == n) -                                            (map unLoc (getConNamesI (unLoc c)))) fixities +                                            (map unL (getConNamesI (unLoc c)))) fixities        ]      patternBit = subPatterns pkg qual @@ -855,7 +857,7 @@ ppShortConstrParts summary dataInst con unicode qual    = case con of        ConDeclH98{ con_args = det                  , con_ex_tvs = tyVars -                , con_forall = L _ forall_ +                , con_forall = forall_                  , con_mb_cxt = cxt                  } -> let context = fromMaybeContext cxt                           header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -895,7 +897,7 @@ ppShortConstrParts summary dataInst con unicode qual            )    where -    occ        = map (nameOccName . getName . unLoc) $ getConNamesI con +    occ        = map (nameOccName . getName . unL) $ getConNamesI con      ppOcc      = hsep (punctuate comma (map (ppBinder summary) occ))      ppOccInfix = hsep (punctuate comma (map (ppBinderInfix summary) occ)) @@ -912,10 +914,10 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)     )   where      -- Find the name of a constructors in the decl (`getConName` always returns a non-empty list) -    aConName = unLoc (head (getConNamesI con)) +    aConName = unL (head (getConNamesI con))      fixity   = ppFixities fixities qual -    occ      = map (nameOccName . getName . unLoc) $ getConNamesI con +    occ      = map (nameOccName . getName . unL) $ getConNamesI con      ppOcc      = hsep (punctuate comma (map (ppBinder False) occ))      ppOccInfix = hsep (punctuate comma (map (ppBinderInfix False) occ)) @@ -927,7 +929,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ con)      decl = case con of        ConDeclH98{ con_args = det                  , con_ex_tvs = tyVars -                , con_forall = L _ forall_ +                , con_forall = forall_                  , con_mb_cxt = cxt                  } -> let context = fromMaybeContext cxt                           header_ = ppConstrHdr forall_ tyVars context unicode qual @@ -994,7 +996,7 @@ ppSideBySideConstr subdocs fixities unicode pkg qual (L _ 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. -    mbDoc = lookup (unLoc $ head $ getConNamesI con) subdocs >>= +    mbDoc = lookup (unL $ head $ getConNamesI con) subdocs >>=              combineDocumentation . fst @@ -1044,7 +1046,7 @@ ppShortField summary unicode qual (ConDeclField _ names ltype _)  -- | Pretty print an expanded pattern (for bundled patterns)  ppSideBySidePat :: [(DocName, Fixity)] -> Unicode -> Qualification -                   -> [Located DocName]    -- ^ pattern name(s) +                   -> [LocatedN DocName]   -- ^ pattern name(s)                     -> LHsSigType DocNameI  -- ^ type of pattern(s)                     -> DocForDecl DocName   -- ^ doc map                     -> SubDecl @@ -1121,7 +1123,7 @@ sumParens = ubxSumList  -- * Rendering of HsType  -------------------------------------------------------------------------------- -ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> Located (HsType DocNameI) -> Html +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification -> HideEmptyContexts -> LHsType DocNameI -> Html  ppLType       unicode qual emptyCtxts y = ppType unicode qual emptyCtxts (unLoc y)  ppLParendType unicode qual emptyCtxts y = ppParendType unicode qual emptyCtxts (unLoc y)  ppLFunLhType  unicode qual emptyCtxts y = ppFunLhType unicode qual emptyCtxts (unLoc y) @@ -1153,7 +1155,7 @@ instance RenderableBndrFlag () where    ppHsTyVarBndr _       qual (UserTyVar _ _ (L _ name)) =        ppDocName qual Raw False name    ppHsTyVarBndr unicode qual (KindedTyVar _ _ name kind) = -      parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> +      parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>                ppLKind unicode qual kind)  instance RenderableBndrFlag Specificity where @@ -1162,10 +1164,10 @@ instance RenderableBndrFlag Specificity where    ppHsTyVarBndr _       qual (UserTyVar _ InferredSpec (L _ name)) =        braces $ ppDocName qual Raw False name    ppHsTyVarBndr unicode qual (KindedTyVar _ SpecifiedSpec name kind) = -      parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> +      parens (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>                ppLKind unicode qual kind)    ppHsTyVarBndr unicode qual (KindedTyVar _ InferredSpec name kind) = -      braces (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> +      braces (ppDocName qual Raw False (unL name) <+> dcolon unicode <+>                ppLKind unicode qual kind)  ppLKind :: Unicode -> Qualification -> LHsKind DocNameI -> Html @@ -1246,9 +1248,9 @@ ppr_mono_ty (HsFunTy _ mult ty1 ty2) u q e =         , arr <+> ppr_mono_lty ty2 u q e         ]     where arr = case mult of -                 HsLinearArrow _ -> lollipop u +                 HsLinearArrow _ _ -> lollipop u                   HsUnrestrictedArrow _ -> arrow u -                 HsExplicitMult _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u +                 HsExplicitMult _ _ m -> multAnnotation <> ppr_mono_lty m u q e <+> arrow u  ppr_mono_ty (HsTupleTy _ con tys) u q _ =    tupleParens con (map (ppLType u q HideEmptyContexts) tys) @@ -1283,7 +1285,7 @@ ppr_mono_ty (HsOpTy _ ty1 op ty2) unicode qual _      -- `(:)` is valid in type signature only as constructor to promoted list      -- and needs to be quoted in code so we explicitly quote it here too.      ppr_op -        | (getOccString . getName . unLoc) op == ":" = promoQuote ppr_op' +        | (getOccString . getName . unL) op == ":" = promoQuote ppr_op'          | otherwise = ppr_op'      ppr_op' = ppLDocName qual Infix op diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs index 7670b193..b8f5ac0f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -31,7 +31,7 @@ import Haddock.Doc (combineDocumentation, emptyMetaDoc,  import Text.XHtml hiding ( name, p, quote )  import Data.Maybe (fromMaybe) -import GHC +import GHC hiding (anchor)  import GHC.Types.Name diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs index d61d6d9b..8f04a21f 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -51,7 +51,7 @@ import Text.XHtml hiding ( name, title, quote )  import Data.Maybe (fromMaybe)  import GHC.Data.FastString ( unpackFS ) -import GHC +import GHC hiding (anchor)  import GHC.Types.Name (nameOccName)  -------------------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs index b324fa38..6dfc60fa 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -27,7 +27,7 @@ import Text.XHtml hiding ( name, p, quote )  import qualified Data.Map as M  import Data.List ( stripPrefix ) -import GHC hiding (LexicalFixity(..)) +import GHC hiding (LexicalFixity(..), anchor)  import GHC.Types.Name  import GHC.Types.Name.Reader  import GHC.Data.FastString (unpackFS) @@ -57,9 +57,10 @@ ppUncheckedLink _ x = linkIdOcc' mdl (Just occ) << occHtml      occHtml = toHtml (showWrapped (occNameString . snd) x) -- TODO: apply ppQualifyName  -- The Bool indicates if it is to be rendered in infix notation -ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName :: Qualification -> Notation -> GenLocated l DocName -> Html  ppLDocName qual notation (L _ d) = ppDocName qual notation True d +  ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html  ppDocName qual notation insertAnchors docName =    case docName of diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a87ba7ce..19630077 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -22,7 +22,7 @@ module Haddock.Convert (  #include "HsVersions.h"  import GHC.Data.Bag ( emptyBag ) -import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..) ) +import GHC.Types.Basic ( TupleSort(..), PromotionFlag(..), DefMethSpec(..), TopLevelFlag(..) )  import GHC.Types.SourceText (SourceText(..))  import GHC.Types.Fixity (LexicalFixity(..))  import GHC.Core.Class @@ -53,7 +53,6 @@ import GHC.Utils.Panic ( assertPanic )  import GHC.Types.Var  import GHC.Types.Var.Set  import GHC.Types.SrcLoc -import GHC.Parser.Annotation (IsUnicodeSyntax(..))  import Haddock.Types  import Haddock.Interface.Specialize @@ -92,20 +91,20 @@ tyThingToLHsDecl prr t = case t of             extractFamilyDecl _           =               Left "tyThingToLHsDecl: impossible associated tycon" -           cvt :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p) +           cvt :: HsTyVarBndr flag GhcRn -> HsType GhcRn               -- Without this signature, we trigger GHC#18932 -           cvt (UserTyVar _ _ n) = HsTyVar noExtField NotPromoted n -           cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noExtField -              (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind +           cvt (UserTyVar _ _ n) = HsTyVar noAnn NotPromoted n +           cvt (KindedTyVar _ _ (L name_loc n) kind) = HsKindSig noAnn +              (L (na2la name_loc) (HsTyVar noAnn NotPromoted (L name_loc n))) kind             -- | Convert a LHsTyVarBndr to an equivalent LHsType. -           hsLTyVarBndrToType :: LHsTyVarBndr flag (GhcPass p) -> LHsType (GhcPass p) +           hsLTyVarBndrToType :: LHsTyVarBndr flag GhcRn -> LHsType GhcRn             hsLTyVarBndrToType = mapLoc cvt             extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltDecl GhcRn             extractFamDefDecl fd rhs = -             TyFamInstDecl $ FamEqn -             { feqn_ext = noExtField +             TyFamInstDecl noAnn $ FamEqn +             { feqn_ext = noAnn               , feqn_tycon = fdLName fd               , feqn_bndrs = HsOuterImplicit{hso_ximplicit = hsq_ext (fdTyVars fd)}               , feqn_pats = map (HsValArg . hsLTyVarBndrToType) $ @@ -119,8 +118,8 @@ tyThingToLHsDecl prr t = case t of             extractAtItem (ATI at_tc def) = do               tyDecl <- synifyTyCon prr Nothing at_tc               famDecl <- extractFamilyDecl tyDecl -             let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def -             pure (noLoc famDecl, defEqnTy) +             let defEqnTy = fmap (noLocA . extractFamDefDecl famDecl . fst) def +             pure (noLocA famDecl, defEqnTy)             atTyClDecls = map extractAtItem (classATItems cl)             (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) @@ -128,14 +127,14 @@ tyThingToLHsDecl prr t = case t of         in withErrs (lefts atTyClDecls) . TyClD noExtField $ ClassDecl           { tcdCtxt = synifyCtx (classSCTheta cl) -         , tcdLName = synifyName cl +         , tcdLName = synifyNameN cl           , tcdTyVars = synifyTyVars vs           , tcdFixity = synifyFixity cl -         , tcdFDs = map (\ (l,r) -> noLoc -                        (map (noLoc . getName) l, map (noLoc . getName) r) ) $ +         , tcdFDs = map (\ (l,r) -> noLocA +                        (FunDep noAnn (map (noLocA . getName) l) (map (noLocA . getName) r)) ) $                           snd $ classTvsFds cl -         , tcdSigs = noLoc (MinimalSig noExtField NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : -                      [ noLoc tcdSig +         , tcdSigs = noLocA (MinimalSig noAnn NoSourceText . noLocA . fmap noLocA $ classMinimalDef cl) : +                      [ noLocA tcdSig                        | clsOp <- classOpItems cl                        , tcdSig <- synifyTcIdSig vs clsOp ]           , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature @@ -152,25 +151,25 @@ tyThingToLHsDecl prr t = case t of    ACoAxiom ax -> synifyAxiom ax >>= allOK    -- a data-constructor alone just gets rendered as a function: -  AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noExtField [synifyName dc] +  AConLike (RealDataCon dc) -> allOK $ SigD noExtField (TypeSig noAnn [synifyNameN dc]      (synifySigWcType ImplicitizeForAll [] (dataConWrapperType dc)))    AConLike (PatSynCon ps) -> -    allOK . SigD noExtField $ PatSynSig noExtField [synifyName ps] (synifyPatSynSigType ps) +    allOK . SigD noExtField $ PatSynSig noAnn [synifyNameN ps] (synifyPatSynSigType ps)    where      withErrs e x = return (e, x)      allOK x = return (mempty, x)  synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn  synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) -  = let name            = synifyName tc +  = let name            = synifyNameN tc          args_types_only = filterOutInvisibleTypes tc args          typats          = map (synifyType WithinType []) args_types_only          annot_typats    = zipWith3 annotHsType args_poly args_types_only typats          hs_rhs          = synifyType WithinType [] rhs          outer_bndrs     = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}                                         -- TODO: this must change eventually -    in FamEqn { feqn_ext    = noExtField +    in FamEqn { feqn_ext    = noAnn                , feqn_tycon  = name                , feqn_bndrs  = outer_bndrs                , feqn_pats   = map HsValArg annot_typats @@ -185,7 +184,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc })    , Just branch <- coAxiomSingleBranch_maybe ax    = return $ InstD noExtField             $ TyFamInstD noExtField -           $ TyFamInstDecl { tfid_eqn = synifyAxBranch tc branch } +           $ TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = synifyAxBranch tc branch }    | Just ax' <- isClosedSynFamilyTyConWithAxiom_maybe tc    , getUnique ax' == getUnique ax   -- without the getUniques, type error @@ -203,7 +202,7 @@ synifyTyCon  synifyTyCon prr _coax tc    | isFunTyCon tc || isPrimTyCon tc    = return $ -    DataDecl { tcdLName = synifyName tc +    DataDecl { tcdLName = synifyNameN tc               , tcdTyVars = HsQTvs  { hsq_ext = []   -- No kind polymorphism                                     , hsq_explicit = zipWith mk_hs_tv                                                              (map scaledThing tyVarKinds) @@ -212,7 +211,7 @@ synifyTyCon prr _coax tc             , tcdFixity = synifyFixity tc -           , tcdDataDefn = HsDataDefn { dd_ext = noExtField +           , tcdDataDefn = HsDataDefn { dd_ext = noAnn                                        , dd_ND = DataType  -- arbitrary lie, they are neither                                                      -- algebraic data nor newtype:                                        , dd_ctxt = Nothing @@ -220,13 +219,13 @@ synifyTyCon prr _coax tc                                        , dd_kindSig = synifyDataTyConReturnKind tc                                                 -- we have their kind accurately:                                        , dd_cons = []  -- No constructors -                                      , dd_derivs = noLoc [] } +                                      , dd_derivs = [] }             , tcdDExt = DataDeclRn False emptyNameSet }    where      -- tyConTyVars doesn't work on fun/prim, but we can make them up:      mk_hs_tv realKind fakeTyVar -      | isLiftedTypeKind realKind = noLoc $ UserTyVar noExtField () (noLoc (getName fakeTyVar)) -      | otherwise = noLoc $ KindedTyVar noExtField () (noLoc (getName fakeTyVar)) (synifyKindSig realKind) +      | isLiftedTypeKind realKind = noLocA $ UserTyVar noAnn () (noLocA (getName fakeTyVar)) +      | otherwise = noLocA $ KindedTyVar noAnn () (noLocA (getName fakeTyVar)) (synifyKindSig realKind)      conKind = defaultType prr (tyConKind tc)      tyVarKinds = fst . splitFunTys . snd . splitInvisPiTys $ conKind @@ -239,7 +238,7 @@ synifyTyCon _prr _coax tc        ClosedSynFamilyTyCon mb          | Just (CoAxiom { co_ax_branches = branches }) <- mb            -> mkFamDecl $ ClosedTypeFamily $ Just -            $ map (noLoc . synifyAxBranch tc) (fromBranches branches) +            $ map (noLocA . synifyAxBranch tc) (fromBranches branches)          | otherwise            -> mkFamDecl $ ClosedTypeFamily $ Just []        BuiltInSynFamTyCon {} @@ -251,9 +250,10 @@ synifyTyCon _prr _coax tc    where      resultVar = famTcResVar tc      mkFamDecl i = return $ FamDecl noExtField $ -      FamilyDecl { fdExt = noExtField +      FamilyDecl { fdExt = noAnn                   , fdInfo = i -                 , fdLName = synifyName tc +                 , fdTopLevel = TopLevel +                 , fdLName = synifyNameN tc                   , fdTyVars = synifyTyVars (tyConVisibleTyVars tc)                   , fdFixity = synifyFixity tc                   , fdResultSig = @@ -266,7 +266,7 @@ synifyTyCon _prr _coax tc  synifyTyCon _prr coax tc    | Just ty <- synTyConRhs_maybe tc    = return $ SynDecl { tcdSExt   = emptyNameSet -                     , tcdLName  = synifyName tc +                     , tcdLName  = synifyNameN tc                       , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)                       , tcdFixity = synifyFixity tc                       , tcdRhs = synifyType WithinType [] ty } @@ -276,9 +276,9 @@ synifyTyCon _prr coax tc    alg_nd = if isNewTyCon tc then NewType else DataType    alg_ctx = synifyCtx (tyConStupidTheta tc)    name = case coax of -    Just a -> synifyName a -- Data families are named according to their +    Just a -> synifyNameN a -- Data families are named according to their                             -- CoAxioms, not their TyCons -    _ -> synifyName tc +    _ -> synifyNameN tc    tyvars = synifyTyVars (tyConVisibleTyVars tc)    kindSig = synifyDataTyConReturnKind tc    -- The data constructors. @@ -301,8 +301,8 @@ synifyTyCon _prr coax tc    consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)    cons = rights consRaw    -- "deriving" doesn't affect the signature, no need to specify any. -  alg_deriv = noLoc [] -  defn = HsDataDefn { dd_ext     = noExtField +  alg_deriv = [] +  defn = HsDataDefn { dd_ext     = noAnn                      , dd_ND      = alg_nd                      , dd_ctxt    = alg_ctx                      , dd_cType   = Nothing @@ -342,15 +342,15 @@ synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity  synifyInjectivityAnn Nothing _ _            = Nothing  synifyInjectivityAnn _       _ NotInjective = Nothing  synifyInjectivityAnn (Just lhs) tvs (Injective inj) = -    let rhs = map (noLoc . tyVarName) (filterByList inj tvs) -    in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs +    let rhs = map (noLocA . tyVarName) (filterByList inj tvs) +    in Just $ noLoc $ InjectivityAnn noAnn (noLocA lhs) rhs  synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn  synifyFamilyResultSig  Nothing    kind     | isLiftedTypeKind kind = noLoc $ NoSig noExtField     | otherwise = noLoc $ KindSig  noExtField (synifyKindSig kind)  synifyFamilyResultSig (Just name) kind = -   noLoc $ TyVarSig noExtField (noLoc $ KindedTyVar noExtField () (noLoc name) (synifyKindSig kind)) +   noLoc $ TyVarSig noExtField (noLocA $ KindedTyVar noAnn () (noLocA 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 @@ -364,7 +364,7 @@ synifyDataCon use_gadt_syntax dc =    -- infix *syntax*.    use_infix_syntax = dataConIsInfix dc    use_named_field_syntax = not (null field_tys) -  name = synifyName dc +  name = synifyNameN dc    -- con_qvars means a different thing depending on gadt-syntax    (_univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc    user_tvbndrs = dataConUserTyVarBinders dc -- Used for GADT data constructors @@ -384,18 +384,18 @@ synifyDataCon use_gadt_syntax dc =                 let tySyn = synifyType WithinType [] (scaledThing ty)                 in case bang of                      (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn -                    bang' -> noLoc $ HsBangTy noExtField bang' tySyn) +                    bang' -> noLocA $ HsBangTy noAnn bang' tySyn)              arg_tys (dataConSrcBangs dc)    field_tys = zipWith con_decl_field (dataConFieldLabels dc) linear_tys -  con_decl_field fl synTy = noLoc $ -    ConDeclField noExtField [noLoc $ FieldOcc (flSelector fl) (noLoc $ mkVarUnqual $ flLabel fl)] synTy +  con_decl_field fl synTy = noLocA $ +    ConDeclField noAnn [noLoc $ FieldOcc (flSelector fl) (noLocA $ mkVarUnqual $ flLabel fl)] synTy                   Nothing    mk_h98_arg_tys :: Either ErrMsg (HsConDeclH98Details GhcRn)    mk_h98_arg_tys = case (use_named_field_syntax, use_infix_syntax) of      (True,True) -> Left "synifyDataCon: contradiction!" -    (True,False) -> return $ RecCon (noLoc field_tys) +    (True,False) -> return $ RecCon (noLocA field_tys)      (False,False) -> return $ PrefixCon noTypeArgs (map hsUnrestricted linear_tys)      (False,True) -> case linear_tys of                       [a,b] -> return $ InfixCon (hsUnrestricted a) (hsUnrestricted b) @@ -403,34 +403,37 @@ synifyDataCon use_gadt_syntax dc =    mk_gadt_arg_tys :: HsConDeclGADTDetails GhcRn    mk_gadt_arg_tys -    | use_named_field_syntax = RecConGADT (noLoc field_tys) +    | use_named_field_syntax = RecConGADT (noLocA field_tys)      | otherwise              = PrefixConGADT (map hsUnrestricted linear_tys)   -- finally we get synifyDataCon's result!   in if use_gadt_syntax         then do           let hat = mk_gadt_arg_tys -         return $ noLoc $ ConDeclGADT -           { con_g_ext  = noExtField +         return $ noLocA $ ConDeclGADT +           { con_g_ext  = noAnn             , con_names  = [name] -           , con_bndrs  = noLoc outer_bndrs +           , con_bndrs  = noLocA outer_bndrs             , con_mb_cxt = ctx             , con_g_args = hat             , con_res_ty = synifyType WithinType [] res_ty             , con_doc    = Nothing }         else do           hat <- mk_h98_arg_tys -         return $ noLoc $ ConDeclH98 -           { con_ext    = noExtField +         return $ noLocA $ ConDeclH98 +           { con_ext    = noAnn             , con_name   = name -           , con_forall = noLoc False +           , con_forall = False             , con_ex_tvs = map (synifyTyVarBndr . (mkTyCoVarBinder InferredSpec)) ex_tvs             , con_mb_cxt = ctx             , con_args   = hat             , con_doc    = Nothing } -synifyName :: NamedThing n => n -> Located Name -synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) +synifyNameN :: NamedThing n => n -> LocatedN Name +synifyNameN n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n) + +-- synifyName :: NamedThing n => n -> LocatedA Name +-- synifyName n = L (noAnnSrcSpan $ srcLocSpan (getSrcLoc n)) (getName n)  -- | Guess the fixity of a something with a name. This isn't quite right, since  -- a user can always declare an infix name in prefix form or a prefix name in @@ -445,7 +448,7 @@ synifyIdSig    -> [TyVar]          -- ^ free variables in the type to convert    -> Id               -- ^ the 'Id' from which to get the type signature    -> Sig GhcRn -synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs t) +synifyIdSig prr s vs i = TypeSig noAnn [synifyNameN i] (synifySigWcType s vs t)    where      t = defaultType prr (varType i) @@ -454,15 +457,15 @@ synifyIdSig prr s vs i = TypeSig noExtField [synifyName i] (synifySigWcType s vs  -- 'ClassOpSig'.  synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]  synifyTcIdSig vs (i, dm) = -  [ ClassOpSig noExtField False [synifyName i] (mainSig (varType i)) ] ++ -  [ ClassOpSig noExtField True [noLoc dn] (defSig dt) +  [ ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i)) ] ++ +  [ ClassOpSig noAnn True [noLocA dn] (defSig dt)    | Just (dn, GenericDM dt) <- [dm] ]    where      mainSig t = synifySigType DeleteTopLevelQuantification vs t      defSig t = synifySigType ImplicitizeForAll vs t  synifyCtx :: [PredType] -> Maybe (LHsContext GhcRn) -synifyCtx ts = Just (noLoc ( map (synifyType WithinType []) ts)) +synifyCtx ts = Just (noLocA ( map (synifyType WithinType []) ts))  synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn @@ -483,8 +486,8 @@ synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv  synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn  synify_ty_var no_kinds flag tv    | isLiftedTypeKind kind || tv `elemVarSet` no_kinds -  = noLoc (UserTyVar noExtField flag (noLoc name)) -  | otherwise = noLoc (KindedTyVar noExtField flag (noLoc name) (synifyKindSig kind)) +  = noLocA (UserTyVar noAnn flag (noLocA name)) +  | otherwise = noLocA (KindedTyVar noAnn flag (noLocA name) (synifyKindSig kind))    where      kind = tyVarKind tv      name = getName tv @@ -501,7 +504,7 @@ annotHsType True ty hs_ty    | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty    = let ki    = typeKind ty          hs_ki = synifyType WithinType [] ki -    in noLoc (HsKindSig noExtField hs_ty hs_ki) +    in noLocA (HsKindSig noAnn hs_ty hs_ki)  annotHsType _    _ hs_ty = hs_ty  -- | For every argument type that a type constructor accepts, @@ -567,7 +570,7 @@ synifyType    -> [TyVar]          -- ^ free variables in the type to convert    -> Type             -- ^ the type to convert    -> LHsType GhcRn -synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExtField NotPromoted $ noLoc (getName tv) +synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (getName tv)  synifyType _ vs (TyConApp tc tys)    = maybe_sig res_ty    where @@ -578,63 +581,63 @@ synifyType _ vs (TyConApp tc tys)        , [TyConApp rep [TyConApp lev []]] <- tys        , rep `hasKey` boxedRepDataConKey        , lev `hasKey` liftedDataConKey -      = noLoc (HsTyVar noExtField NotPromoted (noLoc liftedTypeKindTyConName)) +      = noLocA (HsTyVar noAnn NotPromoted (noLocA liftedTypeKindTyConName))        -- Use non-prefix tuple syntax where possible, because it looks nicer.        | Just sort <- tyConTuple_maybe tc        , tyConArity tc == tys_len -      = noLoc $ HsTupleTy noExtField +      = noLocA $ HsTupleTy noAnn                            (case sort of                                BoxedTuple      -> HsBoxedOrConstraintTuple                                ConstraintTuple -> HsBoxedOrConstraintTuple                                UnboxedTuple    -> HsUnboxedTuple)                             (map (synifyType WithinType vs) vis_tys) -      | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExtField (map (synifyType WithinType vs) vis_tys) +      | isUnboxedSumTyCon tc = noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)        | Just dc <- isPromotedDataCon_maybe tc        , isTupleDataCon dc        , dataConSourceArity dc == length vis_tys -      = noLoc $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys) +      = noLocA $ HsExplicitTupleTy noExtField (map (synifyType WithinType vs) vis_tys)        -- ditto for lists        | getName tc == listTyConName, [ty] <- vis_tys = -         noLoc $ HsListTy noExtField (synifyType WithinType vs ty) +         noLocA $ HsListTy noAnn (synifyType WithinType vs ty)        | tc == promotedNilDataCon, [] <- vis_tys -      = noLoc $ HsExplicitListTy noExtField IsPromoted [] +      = noLocA $ HsExplicitListTy noExtField IsPromoted []        | tc == promotedConsDataCon        , [ty1, ty2] <- vis_tys        = let hTy = synifyType WithinType vs ty1          in case synifyType WithinType vs ty2 of               tTy | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy -                 -> noLoc $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') +                 -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')                   | otherwise -                 -> noLoc $ HsOpTy noExtField hTy (noLoc $ getName tc) tTy +                 -> noLocA $ HsOpTy noExtField hTy (noLocA $ getName tc) tTy        -- ditto for implicit parameter tycons        | tc `hasKey` ipClassKey        , [name, ty] <- tys        , Just x <- isStrLitTy name -      = noLoc $ HsIParamTy noExtField (noLoc $ HsIPName x) (synifyType WithinType vs ty) +      = noLocA $ HsIParamTy noAnn (noLoc $ HsIPName x) (synifyType WithinType vs ty)        -- and equalities        | tc `hasKey` eqTyConKey        , [ty1, ty2] <- tys -      = noLoc $ HsOpTy noExtField +      = noLocA $ HsOpTy noExtField                         (synifyType WithinType vs ty1) -                       (noLoc eqTyConName) +                       (noLocA eqTyConName)                         (synifyType WithinType vs ty2)        -- and infix type operators        | isSymOcc (nameOccName (getName tc))        , ty1:ty2:tys_rest <- vis_tys        = mk_app_tys (HsOpTy noExtField                             (synifyType WithinType vs ty1) -                           (noLoc $ getName tc) +                           (noLocA $ getName tc)                             (synifyType WithinType vs ty2))                     tys_rest        -- Most TyCons:        | otherwise -      = mk_app_tys (HsTyVar noExtField prom $ noLoc (getName tc)) +      = mk_app_tys (HsTyVar noAnn prom $ noLocA (getName tc))                     vis_tys        where          prom = if isPromotedDataCon tc then IsPromoted else NotPromoted          mk_app_tys ty_app ty_args = -          foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) -                (noLoc ty_app) +          foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) +                (noLocA ty_app)                  (map (synifyType WithinType vs) $                   filterOut isCoercionTy ty_args) @@ -646,7 +649,7 @@ synifyType _ vs (TyConApp tc tys)        | tyConAppNeedsKindSig False tc tys_len        = let full_kind  = typeKind (mkTyConApp tc tys)              full_kind' = synifyType WithinType vs full_kind -        in noLoc $ HsKindSig noExtField ty' full_kind' +        in noLocA $ HsKindSig noAnn ty' full_kind'        | otherwise = ty'  synifyType _ vs ty@(AppTy {}) = let @@ -656,19 +659,19 @@ synifyType _ vs ty@(AppTy {}) = let               filterOut isCoercionTy $               filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)                            ty_args -  in foldl (\t1 t2 -> noLoc $ HsAppTy noExtField t1 t2) ty_head' ty_args' +  in foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'  synifyType s vs funty@(FunTy InvisArg _ _ _) = synifySigmaType s vs funty  synifyType _ vs       (FunTy VisArg w t1 t2) = let    s1 = synifyType WithinType vs t1    s2 = synifyType WithinType vs t2    w' = synifyMult vs w -  in noLoc $ HsFunTy noExtField w' s1 s2 +  in noLocA $ HsFunTy noAnn w' s1 s2  synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =    case argf of      Required    -> synifyVisForAllType vs forallty      Invisible _ -> synifySigmaType s vs forallty -synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExtField $ synifyTyLit t +synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t  synifyType s vs (CastTy t _) = synifyType s vs t  synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" @@ -686,9 +689,9 @@ synifyVisForAllType vs ty =        -- absence of an explicit forall        tvs' = orderedFVs (mkVarSet vs) [rho] -  in noLoc $ HsForAllTy { hst_tele = mkHsForAllVisTele sTvs -                        , hst_xforall = noExtField -                        , hst_body  = synifyType WithinType (tvs' ++ vs) rho } +  in noLocA $ HsForAllTy { hst_tele    = mkHsForAllVisTele noAnn sTvs +                         , hst_xforall = noExtField +                         , hst_body    = synifyType WithinType (tvs' ++ vs) rho }  -- | Process a 'Type' which starts with an invisible @forall@ or a constraint  -- into an 'HsType' @@ -703,9 +706,9 @@ synifySigmaType s vs ty =                        , hst_xqual = noExtField                        , hst_body = synifyType WithinType (tvs' ++ vs) tau } -      sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs +      sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs                         , hst_xforall = noExtField -                       , hst_body  = noLoc sPhi } +                       , hst_body  = noLocA sPhi }        sTvs = map synifyTyVarBndr tvs @@ -718,8 +721,8 @@ synifySigmaType s vs ty =      -- Put a forall in if there are any type variables      WithinType -      | not (null tvs) -> noLoc sTy -      | otherwise -> noLoc sPhi +      | not (null tvs) -> noLocA sTy +      | otherwise -> noLocA sPhi      ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau @@ -735,9 +738,9 @@ implicitForAll    -> Type             -- ^ inner type    -> LHsType GhcRn  implicitForAll tycons vs tvs ctx synInner tau -  | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy -  | tvs' /= (binderVars tvs)           = noLoc sTy -  | otherwise                          = noLoc sPhi +  | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy +  | tvs' /= (binderVars tvs)           = noLocA sTy +  | otherwise                          = noLocA sPhi    where    sRho = synInner (tvs' ++ vs) tau    sPhi | null ctx = unLoc sRho @@ -745,9 +748,9 @@ implicitForAll tycons vs tvs ctx synInner tau         = HsQualTy { hst_ctxt = synifyCtx ctx                    , hst_xqual = noExtField                    , hst_body = synInner (tvs' ++ vs) tau } -  sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele sTvs +  sTy = HsForAllTy { hst_tele = mkHsForAllInvisTele noAnn sTvs                     , hst_xforall = noExtField -                   , hst_body = noLoc sPhi } +                   , hst_body = noLocA sPhi }    no_kinds_needed = noKindTyVars tycons tau    sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs @@ -796,9 +799,9 @@ noKindTyVars _ _ = emptyVarSet  synifyMult :: [TyVar] -> Mult -> HsArrow GhcRn  synifyMult vs t = case t of -                    One  -> HsLinearArrow NormalSyntax +                    One  -> HsLinearArrow NormalSyntax Nothing                      Many -> HsUnrestrictedArrow NormalSyntax -                    ty -> HsExplicitMult NormalSyntax (synifyType WithinType vs ty) +                    ty -> HsExplicitMult NormalSyntax Nothing (synifyType WithinType vs ty) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 41801710..b8db6dfd 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -26,7 +26,7 @@ import Control.Arrow  import Data.Char ( isSpace )  import Data.Maybe ( mapMaybe, fromMaybe ) -import Haddock.Types( DocName, DocNameI ) +import Haddock.Types( DocName, DocNameI, XRecCond )  import GHC.Utils.FV as FV  import GHC.Utils.Outputable ( Outputable ) @@ -44,7 +44,6 @@ import GHC.Types.Var.Set ( VarSet, emptyVarSet )  import GHC.Types.Var.Env ( TyVarEnv, extendVarEnv, elemVarEnv, emptyVarEnv )  import GHC.Core.TyCo.Rep ( Type(..) )  import GHC.Core.Type     ( isRuntimeRepVar ) -import GHC.Parser.Annotation (IsUnicodeSyntax(..))  import GHC.Builtin.Types( liftedRepTy )  import           GHC.Data.StringBuffer ( StringBuffer ) @@ -75,20 +74,20 @@ 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 noExtField (FixitySig noExtField filtered ty)) +    filtered -> Just (FixSig noAnn (FixitySig noExtField filtered ty))  filterSigNames _ orig@(MinimalSig _ _ _)      = Just orig  filterSigNames p (TypeSig _ ns ty) =    case filter (p . unLoc) ns of      []       -> Nothing -    filtered -> Just (TypeSig noExtField filtered ty) +    filtered -> Just (TypeSig noAnn filtered ty)  filterSigNames p (ClassOpSig _ is_default ns ty) =    case filter (p . unLoc) ns of      []       -> Nothing -    filtered -> Just (ClassOpSig noExtField is_default filtered ty) +    filtered -> Just (ClassOpSig noAnn is_default filtered ty)  filterSigNames p (PatSynSig _ ns ty) =    case filter (p . unLoc) ns of      []       -> Nothing -    filtered -> Just (PatSynSig noExtField filtered ty) +    filtered -> Just (PatSynSig noAnn filtered ty)  filterSigNames _ _                             = Nothing  ifTrueJust :: Bool -> name -> Maybe name @@ -127,7 +126,7 @@ hsTyVarNameI (KindedTyVar _ _ (L _ n) _) = n  hsLTyVarNameI :: LHsTyVarBndr flag DocNameI -> DocName  hsLTyVarNameI = hsTyVarNameI . unLoc -getConNamesI :: ConDecl DocNameI -> [Located DocName] +getConNamesI :: ConDecl DocNameI -> [LocatedN DocName]  getConNamesI ConDeclH98  {con_name  = name}  = [name]  getConNamesI ConDeclGADT {con_names = names} = names @@ -167,21 +166,22 @@ getGADTConType :: ConDecl DocNameI -> LHsSigType DocNameI  getGADTConType (ConDeclGADT { con_bndrs = L _ outer_bndrs                              , con_mb_cxt = mcxt, con_g_args = args                              , con_res_ty = res_ty }) - = noLoc (HsSig { sig_ext   = noExtField -                , sig_bndrs = outer_bndrs -                , sig_body  = theta_ty }) + = noLocA (HsSig { sig_ext   = noExtField +                 , sig_bndrs = outer_bndrs +                 , sig_body  = theta_ty })   where     theta_ty | Just theta <- mcxt -            = noLoc (HsQualTy { hst_xqual = noExtField, hst_ctxt = Just theta, hst_body = tau_ty }) +            = noLocA (HsQualTy { hst_xqual = noAnn, hst_ctxt = Just theta, hst_body = tau_ty })              | otherwise              = tau_ty  --  tau_ty :: LHsType DocNameI     tau_ty = case args of -              RecConGADT flds -> mkFunTy (noLoc (HsRecTy noExtField (unLoc flds))) res_ty +              RecConGADT flds -> mkFunTy (noLocA (HsRecTy noAnn (unLoc flds))) res_ty                PrefixConGADT pos_args -> foldr mkFunTy res_ty (map hsScaledThing pos_args) -   mkFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) a b) +   mkFunTy :: LHsType DocNameI -> LHsType DocNameI -> LHsType DocNameI +   mkFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) a b)  getGADTConType (ConDeclH98 {}) = panic "getGADTConType"    -- Should only be called on ConDeclGADT @@ -197,10 +197,10 @@ getMainDeclBinderI (ForD _ (ForeignImport _ name _ _)) = [unLoc name]  getMainDeclBinderI (ForD _ (ForeignExport _ _ _ _)) = []  getMainDeclBinderI _ = [] -familyDeclLNameI :: FamilyDecl DocNameI -> Located DocName +familyDeclLNameI :: FamilyDecl DocNameI -> LocatedN DocName  familyDeclLNameI (FamilyDecl { fdLName = n }) = n -tyClDeclLNameI :: TyClDecl DocNameI -> Located DocName +tyClDeclLNameI :: TyClDecl DocNameI -> LocatedN DocName  tyClDeclLNameI (FamDecl { tcdFam = fd })     = familyDeclLNameI fd  tyClDeclLNameI (SynDecl { tcdLName = ln })   = ln  tyClDeclLNameI (DataDecl { tcdLName = ln })  = ln @@ -212,7 +212,7 @@ tcdNameI = unLoc . tyClDeclLNameI  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 noExtField lname (mkEmptyWildCardBndrs (go_sig_ty ltype))) +  = L pos (TypeSig noAnn lname (mkEmptyWildCardBndrs (go_sig_ty ltype)))    where      go_sig_ty (L loc (HsSig { sig_bndrs = bndrs, sig_body = ty }))         = L loc (HsSig { sig_ext = noExtField @@ -230,14 +230,14 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ _ lname ltype))      extra_pred = nlHsTyConApp Prefix cls (lHsQTyVarsToTypes tvs0) -    add_ctxt Nothing              = Just $ noLoc [extra_pred] +    add_ctxt Nothing              = Just $ noLocA [extra_pred]      add_ctxt (Just (L loc preds)) = Just $ L loc (extra_pred : preds)  addClassContext _ _ sig = sig   -- E.g. a MinimalSig is fine  lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsTypeArg GhcRn]  lHsQTyVarsToTypes tvs -  = [ HsValArg $ noLoc (HsTyVar noExtField NotPromoted (noLoc (hsLTyVarName tv))) +  = [ HsValArg $ noLocA (HsTyVar noAnn NotPromoted (noLocA (hsLTyVarName tv)))      | tv <- hsQTvExplicit tvs ] @@ -332,14 +332,13 @@ data Precedence  --  -- We cannot add parens that may be required by fixities because we do not have  -- any fixity information to work with in the first place :(. -reparenTypePrec :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a -                             , MapXRec a, UnXRec a, WrapXRec a ) +reparenTypePrec :: forall a. (XRecCond a)                  => Precedence -> HsType a -> HsType a  reparenTypePrec = go    where    -- Shorter name for 'reparenType' -  go :: Precedence -> HsType a -> HsType a +  go :: XParTy a ~ ApiAnn' AnnParen => Precedence -> HsType a -> HsType a    go _ (HsBangTy x b ty)     = HsBangTy x b (reparenLType ty)    go _ (HsTupleTy x con tys) = HsTupleTy x con (map reparenLType tys)    go _ (HsSumTy x tys)       = HsSumTy x (map reparenLType tys) @@ -361,6 +360,7 @@ reparenTypePrec = go              Nothing -> Nothing              Just c -> Just $ mapXRec @a (\xs -> map (goL (p' xs)) xs) c        in paren p PREC_CTX $ HsQualTy x ctxt' (goL PREC_TOP ty) +    -- = paren p PREC_FUN $ HsQualTy x (fmap (mapXRec @a (map reparenLType)) ctxt) (reparenLType ty)    go p (HsFunTy x w ty1 ty2)      = paren p PREC_FUN $ HsFunTy x w (goL PREC_FUN ty1) (goL PREC_TOP ty2)    go p (HsAppTy x fun_ty arg_ty) @@ -378,40 +378,35 @@ reparenTypePrec = go    go _ t@XHsType{} = t    -- Located variant of 'go' -  goL :: Precedence -> LHsType a -> LHsType a +  goL :: XParTy a ~ ApiAnn' AnnParen => Precedence -> LHsType a -> LHsType a    goL ctxt_prec = mapXRec @a (go ctxt_prec)    -- Optionally wrap a type in parens -  paren :: Precedence            -- Precedence of context +  paren :: XParTy a ~ ApiAnn' AnnParen +        => Precedence            -- Precedence of context          -> Precedence            -- Precedence of top-level operator          -> HsType a -> HsType a  -- Wrap in parens if (ctxt >= op) -  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noExtField . wrapXRec @a +  paren ctxt_prec op_prec | ctxt_prec >= op_prec = HsParTy noAnn . wrapXRec @a                            | otherwise            = id  -- | Add parenthesis around the types in a 'HsType' (see 'reparenTypePrec') -reparenType :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a -               , MapXRec a, UnXRec a, WrapXRec a ) -            => HsType a -> HsType a +reparenType :: XRecCond a => HsType a -> HsType a  reparenType = reparenTypePrec PREC_TOP  -- | Add parenthesis around the types in a 'LHsType' (see 'reparenTypePrec') -reparenLType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a -                          , MapXRec a, UnXRec a, WrapXRec a ) -             => LHsType a -> LHsType a +reparenLType :: forall a. (XRecCond a) => LHsType a -> LHsType a  reparenLType = mapXRec @a reparenType  -- | Add parentheses around the types in an 'HsSigType' (see 'reparenTypePrec') -reparenSigType :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a -                            , MapXRec a, UnXRec a, WrapXRec a ) +reparenSigType :: forall a. ( XRecCond a )                 => HsSigType a -> HsSigType a  reparenSigType (HsSig x bndrs body) =    HsSig x (reparenOuterTyVarBndrs bndrs) (reparenLType body)  reparenSigType v@XHsSigType{} = v  -- | Add parentheses around the types in an 'HsOuterTyVarBndrs' (see 'reparenTypePrec') -reparenOuterTyVarBndrs :: forall flag a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a -                                         , MapXRec a, UnXRec a, WrapXRec a ) +reparenOuterTyVarBndrs :: forall flag a. ( XRecCond a )                         => HsOuterTyVarBndrs flag a -> HsOuterTyVarBndrs flag a  reparenOuterTyVarBndrs imp@HsOuterImplicit{} = imp  reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) = @@ -419,8 +414,7 @@ reparenOuterTyVarBndrs (HsOuterExplicit x exp_bndrs) =  reparenOuterTyVarBndrs v@XHsOuterTyVarBndrs{} = v  -- | Add parentheses around the types in an 'HsForAllTelescope' (see 'reparenTypePrec') -reparenHsForAllTelescope :: forall a. ( XParTy a ~ NoExtField, NoGhcTc a ~ a -                                      , MapXRec a, UnXRec a, WrapXRec a ) +reparenHsForAllTelescope :: forall a. (XRecCond a )                           => HsForAllTelescope a -> HsForAllTelescope a  reparenHsForAllTelescope (HsForAllVis x bndrs) =    HsForAllVis x (map (mapXRec @a reparenTyVar) bndrs) @@ -429,17 +423,13 @@ reparenHsForAllTelescope (HsForAllInvis x bndrs) =  reparenHsForAllTelescope v@XHsForAllTelescope{} = v  -- | Add parenthesis around the types in a 'HsTyVarBndr' (see 'reparenTypePrec') -reparenTyVar :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a -                , MapXRec a, UnXRec a, WrapXRec a ) -             => HsTyVarBndr flag a -> HsTyVarBndr flag a +reparenTyVar :: (XRecCond a) => HsTyVarBndr flag a -> HsTyVarBndr flag a  reparenTyVar (UserTyVar x flag n) = UserTyVar x flag n  reparenTyVar (KindedTyVar x flag n kind) = KindedTyVar x flag n (reparenLType kind)  reparenTyVar v@XTyVarBndr{} = v  -- | Add parenthesis around the types in a 'ConDeclField' (see 'reparenTypePrec') -reparenConDeclField :: ( XParTy a ~ NoExtField, NoGhcTc a ~ a -                       , MapXRec a, UnXRec a, WrapXRec a ) -                    => ConDeclField a -> ConDeclField a +reparenConDeclField :: (XRecCond a) => ConDeclField a -> ConDeclField a  reparenConDeclField (ConDeclField x n t d) = ConDeclField x n (reparenLType t) d  reparenConDeclField c@XConDeclField{} = c @@ -449,13 +439,15 @@ reparenConDeclField c@XConDeclField{} = c  ------------------------------------------------------------------------------- -unL :: Located a -> a +unL :: GenLocated l a -> a  unL (L _ x) = x - -reL :: a -> Located a +reL :: a -> GenLocated l a  reL = L undefined +mapMA :: Monad m => (a -> m b) -> LocatedAn an a -> m (Located b) +mapMA f (L al a) = L (locA al) <$> f a +  -------------------------------------------------------------------------------  -- * NamedThing instances  ------------------------------------------------------------------------------- @@ -763,4 +755,4 @@ defaultRuntimeRepVars = go emptyVarEnv      go _ ty@(CoercionTy {}) = ty  fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI -fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt +fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index b42ae1a3..02e7ed38 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -311,7 +311,7 @@ processModule1 verbosity flags ifaces inst_ifaces hsc_env mod_summary tc_gbl_env      undocumentedExports :: [String]      undocumentedExports = -      [ formatName s n +      [ formatName (locA s) n        | ExportDecl { expItemDecl = L s n                     , expItemMbDoc = (Documentation Nothing _, _)                     } <- ifaceExportItems interface diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 6bc8b8c8..e8a79b2b 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -30,14 +30,11 @@ import qualified Data.Set as Set  import GHC.Data.FastString (unpackFS)  import GHC.Core.Class -import GHC.Driver.Session  import GHC.Core (isOrphan) -import GHC.Utils.Error  import GHC.Core.FamInstEnv  import GHC  import GHC.Core.InstEnv  import GHC.Unit.Module.Env ( ModuleSet, moduleSetElts ) -import GHC.Utils.Monad (liftIO)  import GHC.Types.Name  import GHC.Types.Name.Env  import GHC.Utils.Outputable (text, sep, (<+>)) @@ -104,7 +101,7 @@ attachToExportItem index expInfo getInstDoc getFixity export =              fam_instances = maybeToList mb_instances >>= snd              fam_insts = [ ( synFamInst                            , getInstDoc n -                          , spanNameE n synFamInst (L eSpan (tcdName d)) +                          , spanNameE n synFamInst (L (locA eSpan) (tcdName d))                            , nameModule_maybe n                            )                          | i <- sortBy (comparing instFam) fam_instances @@ -116,7 +113,7 @@ attachToExportItem index expInfo getInstDoc getFixity export =                          ]              cls_insts = [ ( synClsInst                            , getInstDoc n -                          , spanName n synClsInst (L eSpan (tcdName d)) +                          , spanName n synClsInst (L (locA eSpan) (tcdName d))                            , nameModule_maybe n                            )                          | let is = [ (instanceSig i, getName i) | i <- cls_instances ] diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 4e788260..a280c0b2 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -79,6 +79,8 @@ import GHC.Unit.Module.Warnings (WarningTxt (..), Warnings (..))  import GHC.Unit.State (PackageName (..), UnitState, lookupModuleInAllUnits)  import qualified GHC.Utils.Outputable as O  import GHC.Utils.Panic (pprPanic) +import GHC.HsToCore.Docs hiding (mkMaps) +import GHC.Unit.Module.Warnings  newtype IfEnv m = IfEnv    { @@ -200,7 +202,7 @@ createInterface1 flags unit_state mod_sum tc_gbl_env ifaces inst_ifaces = do      loc_splices :: [SrcSpan]      loc_splices = case tcg_rn_decls of        Nothing -> [] -      Just HsGroup { hs_splcds } -> [ loc | L loc _ <- hs_splcds ] +      Just HsGroup { hs_splcds } -> [ locA loc | L loc _ <- hs_splcds ]    decls <- case tcg_rn_decls of      Nothing -> do @@ -530,7 +532,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do                          , [(Name, IntMap (MDoc Name))]                          , [(Name,  [LHsDecl GhcRn])]                          ) -    mappings (ldecl@(L (RealSrcSpan l _) decl), docStrs) = do +    mappings (ldecl@(L (SrcSpanAnn _ (RealSrcSpan l _)) decl), docStrs) = do        let declDoc :: [HsDocString] -> IntMap HsDocString                    -> ErrMsgM (Maybe (MDoc Name), IntMap (MDoc Name))            declDoc strs m = do @@ -559,7 +561,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do          seqList subDocs `seq`          seqList subArgs `seq`          pure (dm, am, cm) -    mappings (L (UnhelpfulSpan _) _, _) = pure ([], [], []) +    mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = pure ([], [], [])      instanceMap :: Map RealSrcSpan Name      instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] @@ -570,7 +572,7 @@ mkMaps dflags pkgName gre instances decls thDocs = do                -- The CoAx's loc is the whole line, but only for TFs. The                -- workaround is to dig into the family instance declaration and                -- get the identifier with the right location. -              TyFamInstD _ (TyFamInstDecl d') -> getLoc (feqn_tycon d') +              TyFamInstD _ (TyFamInstDecl _ d') -> getLocA (feqn_tycon d')                _ -> getInstLoc d      names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See note [2].      names _ decl = getMainDeclBinder decl @@ -701,7 +703,8 @@ 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 +          let l = locA l'            -- Top-level binding without type signature            export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap            return [export] @@ -734,7 +737,7 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames                    L loc (TyClD _ ClassDecl {..}) -> do                      mdef <- minimalDef t -                    let sig = maybeToList $ fmap (noLoc . MinimalSig noExtField NoSourceText . noLoc . fmap noLoc) mdef +                    let sig = maybeToList $ fmap (noLocA . MinimalSig noAnn NoSourceText . noLocA . fmap noLocA) mdef                      availExportDecl avail                        (L loc $ TyClD noExtField ClassDecl { tcdSigs = sig ++ tcdSigs, .. }) docs_ @@ -892,7 +895,7 @@ hiDecl dflags t = do      Just x -> case tyThingToLHsDecl ShowRuntimeRep x of        Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing        Right (m, t') -> liftErrMsg (tell $ map bugWarn m) -                      >> return (Just $ noLoc t') +                      >> return (Just $ noLocA t')      where        warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>                     O.comma O.<+> O.quotes (O.ppr t) O.<+> @@ -912,7 +915,7 @@ hiValExportItem dflags name nLoc doc splice fixity = do      Nothing -> return (ExportNoDecl name [])      Just decl -> return (ExportDecl (fixSpan decl) [] doc [] [] fixities splice)    where -    fixSpan (L l t) = L (SrcLoc.combineSrcSpans l nLoc) t +    fixSpan (L (SrcSpanAnn a l) t) = L (SrcSpanAnn a (SrcLoc.combineSrcSpans l nLoc)) t      fixities = case fixity of        Just f  -> [(name, f)]        Nothing -> [] @@ -1101,7 +1104,7 @@ extractDecl declMap name decl                                 , name `elem` map unLoc (concatMap (getConNames . unLoc) (dd_cons dd))                                 ]              in case matches of -                [d0] -> extractDecl declMap name (noLoc (InstD noExtField (DataFamInstD noExtField d0))) +                [d0] -> extractDecl declMap name (noLocA (InstD noExtField (DataFamInstD noExtField d0)))                  _    -> Left "internal: extractDecl (ClsInstD)"          | otherwise ->              let matches = [ d' | L _ d'@(DataFamInstDecl d ) @@ -1113,7 +1116,7 @@ extractDecl declMap name decl                                 , extFieldOcc n == name                            ]              in case matches of -              [d0] -> extractDecl declMap name (noLoc . InstD noExtField $ DataFamInstD noExtField d0) +              [d0] -> extractDecl declMap name (noLocA . InstD noExtField $ DataFamInstD noExtField d0)                _ -> Left "internal: extractDecl (ClsInstD)"        _ -> Left ("extractDecl: Unhandled decl for " ++ getOccString name) @@ -1143,21 +1146,21 @@ extractPatternSyn nm t tvs cons =          typ = longArrow args (data_ty con)          typ' =            case con of -            ConDeclH98 { con_mb_cxt = Just cxt } -> noLoc (HsQualTy noExtField (Just cxt) typ) +            ConDeclH98 { con_mb_cxt = Just cxt } -> noLocA (HsQualTy noExtField (Just cxt) typ)              _ -> typ -        typ'' = noLoc (HsQualTy noExtField (Just (noLoc [])) typ') -    in PatSynSig noExtField [noLoc nm] (mkEmptySigType typ'') +        typ'' = noLocA (HsQualTy noExtField Nothing typ') +    in PatSynSig noAnn [noLocA nm] (mkEmptySigType typ'')    longArrow :: [LHsType GhcRn] -> LHsType GhcRn -> LHsType GhcRn -  longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x y)) output inputs +  longArrow inputs output = foldr (\x y -> noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x y)) output inputs    data_ty con      | ConDeclGADT{} <- con = con_res_ty con -    | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs +    | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs                      where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn                            mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty                            mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki -                          mkAppTyArg f (HsArgPar _) = HsParTy noExtField f +                          mkAppTyArg f (HsArgPar _) = HsParTy noAnn f  extractRecSel :: Name -> Name -> [LHsTypeArg GhcRn] -> [LConDecl GhcRn]                -> Either ErrMsg (LSig GhcRn) @@ -1166,7 +1169,7 @@ extractRecSel _ _ _ [] = Left "extractRecSel: selector not found"  extractRecSel nm t tvs (L _ con : rest) =    case getRecConArgs_maybe con of      Just (L _ fields) | ((l,L _ (ConDeclField _ _nn ty _)) : _) <- matching_fields fields -> -      pure (L l (TypeSig noExtField [noLoc nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty)))))) +      pure (L (noAnnSrcSpan l) (TypeSig noAnn [noLocA nm] (mkEmptyWildCardBndrs $ mkEmptySigType (noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) data_ty (getBangType ty))))))      _ -> extractRecSel nm t tvs rest   where    matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1175,11 +1178,11 @@ extractRecSel nm t tvs (L _ con : rest) =    data_ty      -- ResTyGADT _ ty <- con_res con = ty      | ConDeclGADT{} <- con = con_res_ty con -    | otherwise = foldl' (\x y -> noLoc (mkAppTyArg x y)) (noLoc (HsTyVar noExtField NotPromoted (noLoc t))) tvs +    | otherwise = foldl' (\x y -> noLocA (mkAppTyArg x y)) (noLocA (HsTyVar noAnn NotPromoted (noLocA t))) tvs                     where mkAppTyArg :: LHsType GhcRn -> LHsTypeArg GhcRn -> HsType GhcRn                           mkAppTyArg f (HsValArg ty) = HsAppTy noExtField f ty                           mkAppTyArg f (HsTypeArg l ki) = HsAppKindTy l f ki -                         mkAppTyArg f (HsArgPar _) = HsParTy noExtField f +                         mkAppTyArg f (HsArgPar _) = HsParTy noAnn f  -- | 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 b62f79ce..2833df49 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -34,6 +34,7 @@ import qualified Data.Map as Map hiding ( Map )  import qualified Data.Set as Set  import Prelude hiding (mapM)  import GHC.HsToCore.Docs +import GHC.Types.Basic ( TopLevelFlag(..) )  -- | Traverse docstrings and ASTs in the Haddock interface, renaming 'Name' to  -- 'DocName'. @@ -173,10 +174,9 @@ rename :: Name -> RnM DocName  rename = lookupRn -renameL :: Located Name -> RnM (Located DocName) +renameL :: GenLocated l Name -> RnM (GenLocated l DocName)  renameL = mapM rename -  renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI]  renameExportItems = mapM renameExportItem @@ -235,10 +235,10 @@ renameFamilyResultSig (L loc (TyVarSig _ bndr))           ; return (L loc (TyVarSig noExtField bndr')) }  renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) -renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) +renameInjectivityAnn (L loc (InjectivityAnn _ lhs rhs))      = do { lhs' <- renameL lhs           ; rhs' <- mapM renameL rhs -         ; return (L loc (InjectivityAnn lhs' rhs')) } +         ; return (L loc (InjectivityAnn noExtField lhs' rhs')) }  renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)                            -> RnM (Maybe (LInjectivityAnn DocNameI)) @@ -246,75 +246,75 @@ renameMaybeInjectivityAnn = traverse renameInjectivityAnn  renameArrow :: HsArrow GhcRn -> RnM (HsArrow DocNameI)  renameArrow (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u) -renameArrow (HsLinearArrow u) = return (HsLinearArrow u) -renameArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameArrow (HsLinearArrow u a) = return (HsLinearArrow u a) +renameArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p  renameType :: HsType GhcRn -> RnM (HsType DocNameI)  renameType t = case t of    HsForAllTy { hst_tele = tele, hst_body = ltype } -> do      tele'  <- renameHsForAllTelescope tele      ltype' <- renameLType ltype -    return (HsForAllTy { hst_xforall = noExtField +    return (HsForAllTy { hst_xforall = noAnn                         , hst_tele = tele', hst_body = ltype' })    HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do      lcontext' <- traverse renameLContext lcontext      ltype'    <- renameLType ltype -    return (HsQualTy { hst_xqual = noExtField, hst_ctxt = lcontext', hst_body = ltype' }) +    return (HsQualTy { hst_xqual = noAnn, hst_ctxt = lcontext', hst_body = ltype' }) -  HsTyVar _ ip (L l n) -> return . HsTyVar noExtField ip . L l =<< rename n -  HsBangTy _ b ltype -> return . HsBangTy noExtField b =<< renameLType ltype +  HsTyVar _ ip (L l n) -> return . HsTyVar noAnn ip . L l =<< rename n +  HsBangTy _ b ltype -> return . HsBangTy noAnn b =<< renameLType ltype -  HsStarTy _ isUni -> return (HsStarTy noExtField isUni) +  HsStarTy _ isUni -> return (HsStarTy noAnn isUni)    HsAppTy _ a b -> do      a' <- renameLType a      b' <- renameLType b -    return (HsAppTy noExtField a' b') +    return (HsAppTy noAnn a' b')    HsAppKindTy _ a b -> do      a' <- renameLType a      b' <- renameLKind b -    return (HsAppKindTy noExtField a' b') +    return (HsAppKindTy noAnn a' b')    HsFunTy _ w a b -> do      a' <- renameLType a      b' <- renameLType b      w' <- renameArrow w -    return (HsFunTy noExtField w' a' b') +    return (HsFunTy noAnn w' a' b') -  HsListTy _ ty -> return . (HsListTy noExtField) =<< renameLType ty -  HsIParamTy _ n ty -> liftM (HsIParamTy noExtField n) (renameLType ty) +  HsListTy _ ty -> return . (HsListTy noAnn) =<< renameLType ty +  HsIParamTy _ n ty -> liftM (HsIParamTy noAnn n) (renameLType ty) -  HsTupleTy _ b ts -> return . HsTupleTy noExtField b =<< mapM renameLType ts -  HsSumTy _ ts -> HsSumTy noExtField <$> mapM renameLType ts +  HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts +  HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts    HsOpTy _ a (L loc op) b -> do      op' <- rename op      a'  <- renameLType a      b'  <- renameLType b -    return (HsOpTy noExtField a' (L loc op') b') +    return (HsOpTy noAnn a' (L loc op') b') -  HsParTy _ ty -> return . (HsParTy noExtField) =<< renameLType ty +  HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty    HsKindSig _ ty k -> do      ty' <- renameLType ty      k' <- renameLKind k -    return (HsKindSig noExtField ty' k') +    return (HsKindSig noAnn ty' k')    HsDocTy _ ty doc -> do      ty' <- renameLType ty      doc' <- renameLDocHsSyn doc -    return (HsDocTy noExtField ty' doc') +    return (HsDocTy noAnn ty' doc') -  HsTyLit _ x -> return (HsTyLit noExtField x) +  HsTyLit _ x -> return (HsTyLit noAnn x) -  HsRecTy _ a               -> HsRecTy noExtField <$> mapM renameConDeclFieldField a +  HsRecTy _ a               -> HsRecTy noAnn <$> mapM renameConDeclFieldField a    XHsType a                 -> pure (XHsType a) -  HsExplicitListTy i a b  -> HsExplicitListTy i a <$> mapM renameLType b -  HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b +  HsExplicitListTy _ a b  -> HsExplicitListTy noAnn a <$> mapM renameLType b +  HsExplicitTupleTy _ b   -> HsExplicitTupleTy noAnn <$> mapM renameLType b    HsSpliceTy _ s          -> renameHsSpliceTy s -  HsWildCardTy a          -> pure (HsWildCardTy a) +  HsWildCardTy _          -> pure (HsWildCardTy noAnn)  renameSigType :: HsSigType GhcRn -> RnM (HsSigType DocNameI)  renameSigType (HsSig { sig_bndrs = bndrs, sig_body = body }) = do @@ -341,21 +341,21 @@ renameLHsQTyVars (HsQTvs { hsq_explicit = tvs })  renameHsForAllTelescope :: HsForAllTelescope GhcRn -> RnM (HsForAllTelescope DocNameI)  renameHsForAllTelescope tele = case tele of -  HsForAllVis   x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs -                              pure $ HsForAllVis x bndrs' -  HsForAllInvis x bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs -                              pure $ HsForAllInvis x bndrs' +  HsForAllVis   _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs +                              pure $ HsForAllVis noExtField bndrs' +  HsForAllInvis _ bndrs -> do bndrs' <- mapM renameLTyVarBndr bndrs +                              pure $ HsForAllInvis noExtField bndrs'  renameLTyVarBndr :: LHsTyVarBndr flag GhcRn -> RnM (LHsTyVarBndr flag DocNameI) -renameLTyVarBndr (L loc (UserTyVar x fl (L l n))) +renameLTyVarBndr (L loc (UserTyVar _ fl (L l n)))    = do { n' <- rename n -       ; return (L loc (UserTyVar x fl (L l n'))) } -renameLTyVarBndr (L loc (KindedTyVar x fl (L lv n) kind)) +       ; return (L loc (UserTyVar noExtField fl (L l n'))) } +renameLTyVarBndr (L loc (KindedTyVar _ fl (L lv n) kind))    = do { n' <- rename n         ; kind' <- renameLKind kind -       ; return (L loc (KindedTyVar x fl (L lv n') kind')) } +       ; return (L loc (KindedTyVar noExtField fl (L lv n') kind')) } -renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) +renameLContext :: LocatedC [LHsType GhcRn] -> RnM (LocatedC [LHsType DocNameI])  renameLContext (L loc context) = do    context' <- mapM renameLType context    return (L loc context') @@ -406,8 +406,8 @@ renameDecl decl = case decl of      return (DerivD noExtField d')    _ -> error "renameDecl" -renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) -renameLThing fn (L loc x) = return . L loc =<< fn x +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> LocatedAn an (a GhcRn) -> RnM (Located (a DocNameI)) +renameLThing fn (L loc x) = return . L (locA loc) =<< fn x  renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI)  renameTyClD d = case d of @@ -446,12 +446,13 @@ renameTyClD d = case d of                        , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdCExt = noExtField })    where -    renameLFunDep (L loc (xs, ys)) = do +    renameLFunDep :: LHsFunDep GhcRn -> RnM (LHsFunDep DocNameI) +    renameLFunDep (L loc (FunDep _ xs ys)) = do        xs' <- mapM rename (map unLoc xs)        ys' <- mapM rename (map unLoc ys) -      return (L loc (map noLoc xs', map noLoc ys')) +      return (L (locA loc) (FunDep noExtField (map noLocA xs') (map noLocA ys'))) -    renameLSig (L loc sig) = return . L loc =<< renameSig sig +    renameLSig (L loc sig) = return . L (locA loc) =<< renameSig sig  renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI)  renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname @@ -464,7 +465,8 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname      ltyvars'     <- renameLHsQTyVars ltyvars      result'      <- renameFamilyResultSig result      injectivity' <- renameMaybeInjectivityAnn injectivity -    return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdLName = lname' +    return (FamilyDecl { fdExt = noExtField, fdInfo = info', fdTopLevel = TopLevel +                       , fdLName = lname'                         , fdTyVars = ltyvars'                         , fdFixity = fixity                         , fdResultSig = result' @@ -492,12 +494,12 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType                             , dd_kindSig = k, dd_cons = cons }) = do      lcontext' <- traverse renameLContext lcontext      k'        <- renameMaybeLKind k -    cons'     <- mapM (mapM renameCon) cons +    cons'     <- mapM (mapMA renameCon) cons      -- I don't think we need the derivings, so we return Nothing      return (HsDataDefn { dd_ext = noExtField                         , dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType                         , dd_kindSig = k', dd_cons = cons' -                       , dd_derivs = noLoc [] }) +                       , dd_derivs = [] })  renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)  renameCon decl@(ConDeclH98 { con_name = lname, con_ex_tvs = ltyvars @@ -537,7 +539,7 @@ renameH98Details :: HsConDeclH98Details GhcRn                   -> RnM (HsConDeclH98Details DocNameI)  renameH98Details (RecCon (L l fields)) = do    fields' <- mapM renameConDeclFieldField fields -  return (RecCon (L l fields')) +  return (RecCon (L (locA l) fields'))  renameH98Details (PrefixCon ts ps) = PrefixCon ts <$> mapM renameHsScaled ps  renameH98Details (InfixCon a b) = do    a' <- renameHsScaled a @@ -548,7 +550,7 @@ renameGADTDetails :: HsConDeclGADTDetails GhcRn                    -> RnM (HsConDeclGADTDetails DocNameI)  renameGADTDetails (RecConGADT (L l fields)) = do    fields' <- mapM renameConDeclFieldField fields -  return (RecConGADT (L l fields')) +  return (RecConGADT (L (locA l) fields'))  renameGADTDetails (PrefixConGADT ps) = PrefixConGADT <$> mapM renameHsScaled ps  renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) @@ -556,7 +558,7 @@ renameConDeclFieldField (L l (ConDeclField _ names t doc)) = do    names' <- mapM renameLFieldOcc names    t'   <- renameLType t    doc' <- mapM renameLDocHsSyn doc -  return $ L l (ConDeclField noExtField names' t' doc') +  return $ L (locA l) (ConDeclField noExtField names' t' doc')  renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)  renameLFieldOcc (L l (FieldOcc sel lbl)) = do @@ -621,10 +623,10 @@ renameDerivD (DerivDecl { deriv_type = ty                      , deriv_overlap_mode = omode })  renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) -renameDerivStrategy StockStrategy    = pure StockStrategy -renameDerivStrategy AnyclassStrategy = pure AnyclassStrategy -renameDerivStrategy NewtypeStrategy  = pure NewtypeStrategy -renameDerivStrategy (ViaStrategy ty) = ViaStrategy <$> renameLSigType ty +renameDerivStrategy (StockStrategy a)    = pure (StockStrategy a) +renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a) +renameDerivStrategy (NewtypeStrategy a)  = pure (NewtypeStrategy a) +renameDerivStrategy (ViaStrategy ty)     = ViaStrategy <$> renameLSigType ty  renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)  renameClsInstD (ClsInstDecl { cid_overlap_mode = omode @@ -642,7 +644,7 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode  renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)  renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })    = do { eqn' <- renameTyFamInstEqn eqn -       ; return (TyFamInstDecl { tfid_eqn = eqn' }) } +       ; return (TyFamInstDecl { tfid_xtn = noExtField, tfid_eqn = eqn' }) }  renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)  renameTyFamInstEqn (FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index 5ef5d92d..16f00fda 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -19,7 +19,6 @@ import GHC  import GHC.Types.Name  import GHC.Data.FastString  import GHC.Builtin.Types ( listTyConName, unrestrictedFunTyConName ) -import GHC.Parser.Annotation (IsUnicodeSyntax(..))  import Control.Monad  import Control.Monad.Trans.State @@ -75,7 +74,7 @@ specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]                -> Sig GhcRn                -> Sig GhcRn  specializeSig bndrs typs (TypeSig _ lnames typ) = -  TypeSig noExtField lnames (typ {hswc_body = noLoc typ'}) +  TypeSig noAnn lnames (typ {hswc_body = noLocA typ'})    where      true_type :: HsSigType GhcRn      true_type = unLoc (dropWildCards typ) @@ -111,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) -    | getName name == listTyConName = HsListTy noExtField ltyp +    | getName name == listTyConName = HsListTy noAnn ltyp  sugarLists typ = typ @@ -122,7 +121,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 noExtField HsBoxedOrConstraintTuple apps +        | isBuiltInSyntax name' && suitable = HsTupleTy noAnn HsBoxedOrConstraintTuple apps        where          name' = getName name          strName = getOccString name @@ -132,10 +131,10 @@ sugarTuples typ =      aux _ _ = typ -sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) +sugarOperators :: HsType GhcRn -> HsType GhcRn  sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)      | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb -    | unrestrictedFunTyConName == name' = HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) la lb +    | unrestrictedFunTyConName == name' = HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) la lb    where      name' = getName name  sugarOperators typ = typ @@ -286,7 +285,7 @@ renameType (HsQualTy x lctxt lt) =      HsQualTy x          <$> renameMContext lctxt          <*> renameLType lt -renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name +renameType (HsTyVar x ip name) = HsTyVar x ip <$> locatedN renameName name  renameType t@(HsStarTy _ _) = pure t  renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la  renameType (HsAppKindTy x lt lk) = HsAppKindTy x <$> renameLType lt <*> renameLKind lk @@ -295,7 +294,7 @@ renameType (HsListTy x lt) = HsListTy 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 +    HsOpTy x <$> renameLType la <*> locatedN renameName lop <*> renameLType lb  renameType (HsParTy x lt) = HsParTy x <$> renameLType lt  renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt  renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk @@ -312,7 +311,7 @@ renameType t@(HsTyLit _ _) = pure t  renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)  renameHsArrow :: HsArrow GhcRn -> Rename (IdP GhcRn) (HsArrow GhcRn) -renameHsArrow (HsExplicitMult u p) = HsExplicitMult u <$> renameLType p +renameHsArrow (HsExplicitMult u a p) = HsExplicitMult u a <$> renameLType p  renameHsArrow mult = pure mult @@ -342,9 +341,9 @@ renameForAllTelescope (HsForAllInvis x bndrs) =    HsForAllInvis x <$> mapM renameLBinder bndrs  renameBinder :: HsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr flag GhcRn) -renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> located renameName lname +renameBinder (UserTyVar x fl lname) = UserTyVar x fl <$> locatedN renameName lname  renameBinder (KindedTyVar x fl lname lkind) = -  KindedTyVar x fl <$> located renameName lname <*> located renameType lkind +  KindedTyVar x fl <$> locatedN renameName lname <*> located renameType lkind  renameLBinder :: LHsTyVarBndr flag GhcRn -> Rename (IdP GhcRn) (LHsTyVarBndr flag GhcRn)  renameLBinder = located renameBinder @@ -397,9 +396,12 @@ alternativeNames name =      str = nameRepString name -located :: Functor f => (a -> f b) -> Located a -> f (Located b) +located :: Functor f => (a -> f b) -> GenLocated l a -> f (GenLocated l b)  located f (L loc e) = L loc <$> f e +locatedN :: Functor f => (a -> f b) -> LocatedN a -> f (LocatedN b) +locatedN f (L loc e) = L loc <$> f e +  tyVarName :: HsTyVarBndr flag GhcRn -> IdP GhcRn  tyVarName (UserTyVar _ _ name) = unLoc name diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 83c9dd72..5c6f09a3 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,4 +1,5 @@  {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} +{-# LANGUAGE ConstraintKinds #-}  {-# LANGUAGE FlexibleContexts #-}  {-# LANGUAGE PartialTypeSignatures #-}  {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] @@ -46,6 +47,7 @@ import Data.Void (Void)  import Documentation.Haddock.Types  import GHC.Types.Basic (PromotionFlag(..))  import GHC.Types.Fixity (Fixity(..)) +import GHC.Types.Var (Specificity)  import GHC  import GHC.Driver.Session (Language) @@ -406,13 +408,13 @@ instance (OutputableBndrId p)  -- 'PseudoFamilyDecl' type is introduced.  data PseudoFamilyDecl name = PseudoFamilyDecl      { pfdInfo :: FamilyInfo name -    , pfdLName :: Located (IdP name) +    , pfdLName :: LocatedN (IdP name)      , pfdTyVars :: [LHsType name]      , pfdKindSig :: LFamilyResultSig name      } -mkPseudoFamilyDecl :: FamilyDecl (GhcPass p) -> PseudoFamilyDecl (GhcPass p) +mkPseudoFamilyDecl :: FamilyDecl GhcRn -> PseudoFamilyDecl GhcRn  mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl      { pfdInfo = fdInfo      , pfdLName = fdLName @@ -420,12 +422,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl      , pfdKindSig = fdResultSig      }    where -    mkType :: HsTyVarBndr flag (GhcPass p) -> HsType (GhcPass p) +    mkType :: HsTyVarBndr flag GhcRn -> HsType GhcRn      mkType (KindedTyVar _ _ (L loc name) lkind) = -        HsKindSig noExtField tvar lkind +        HsKindSig noAnn tvar lkind        where -        tvar = L loc (HsTyVar noExtField NotPromoted (L loc name)) -    mkType (UserTyVar _ _ name) = HsTyVar noExtField NotPromoted name +        tvar = L (na2la loc) (HsTyVar noAnn NotPromoted (L loc name)) +    mkType (UserTyVar _ _ name) = HsTyVar noAnn NotPromoted name  -- | An instance head that may have documentation and a source location. @@ -694,36 +696,69 @@ liftErrMsg = writer . runWriter  -- * Pass sensitive types  ----------------------------------------------------------------------------- -type instance XRec DocNameI a = Located a +type instance XRec DocNameI a = GenLocated (Anno a) a  instance UnXRec DocNameI where    unXRec = unLoc  instance MapXRec DocNameI where    mapXRec = fmap -instance WrapXRec DocNameI where -  wrapXRec = noLoc - -type instance XForAllTy        DocNameI = NoExtField -type instance XQualTy          DocNameI = NoExtField -type instance XTyVar           DocNameI = NoExtField -type instance XStarTy          DocNameI = NoExtField -type instance XAppTy           DocNameI = NoExtField -type instance XAppKindTy       DocNameI = NoExtField -type instance XFunTy           DocNameI = NoExtField -type instance XListTy          DocNameI = NoExtField -type instance XTupleTy         DocNameI = NoExtField -type instance XSumTy           DocNameI = NoExtField -type instance XOpTy            DocNameI = NoExtField -type instance XParTy           DocNameI = NoExtField -type instance XIParamTy        DocNameI = NoExtField -type instance XKindSig         DocNameI = NoExtField +instance WrapXRec DocNameI (HsType DocNameI) where +  wrapXRec = noLocA + +type instance Anno DocName                           = SrcSpanAnnN +type instance Anno (HsTyVarBndr flag DocNameI)       = SrcSpanAnnA +type instance Anno [LocatedA (HsType DocNameI)]      = SrcSpanAnnC +type instance Anno (HsType DocNameI)                 = SrcSpanAnnA +type instance Anno (DataFamInstDecl DocNameI)        = SrcSpanAnnA +type instance Anno (DerivStrategy DocNameI)          = SrcSpan +type instance Anno (FieldOcc DocNameI)               = SrcSpan +type instance Anno (ConDeclField DocNameI)           = SrcSpan +type instance Anno (Located (ConDeclField DocNameI)) = SrcSpan +type instance Anno [Located (ConDeclField DocNameI)] = SrcSpan +type instance Anno (ConDecl DocNameI)                = SrcSpan +type instance Anno (FunDep DocNameI)                 = SrcSpan +type instance Anno (TyFamInstDecl DocNameI)          = SrcSpanAnnA +type instance Anno [LocatedA (TyFamInstDecl DocNameI)] = SrcSpanAnnL +type instance Anno (FamilyDecl DocNameI)               = SrcSpan +type instance Anno (Sig DocNameI)                      = SrcSpan +type instance Anno (InjectivityAnn DocNameI)           = SrcSpan +type instance Anno (HsDecl DocNameI)                   = SrcSpanAnnA +type instance Anno (FamilyResultSig DocNameI)          = SrcSpan +type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA +type instance Anno (HsSigType DocNameI)                     = SrcSpanAnnA + +type XRecCond a +  = ( XParTy a           ~ ApiAnn' AnnParen +    -- , XParTy (NoGhcTc a) ~ ApiAnn' AnnParen +    -- , NoGhcTcPass (NoGhcTcPass a) ~ NoGhcTcPass a +    -- , IsPass a +    , NoGhcTc a ~ a +    , MapXRec a +    , UnXRec a +    , WrapXRec a (HsType a) +    ) + +type instance XForAllTy        DocNameI = ApiAnn +type instance XQualTy          DocNameI = ApiAnn +type instance XTyVar           DocNameI = ApiAnn +type instance XStarTy          DocNameI = ApiAnn +type instance XAppTy           DocNameI = ApiAnn +type instance XAppKindTy       DocNameI = ApiAnn +type instance XFunTy           DocNameI = ApiAnn +type instance XListTy          DocNameI = ApiAnn' AnnParen +type instance XTupleTy         DocNameI = ApiAnn' AnnParen +type instance XSumTy           DocNameI = ApiAnn' AnnParen +type instance XOpTy            DocNameI = ApiAnn +type instance XParTy           DocNameI = ApiAnn' AnnParen +type instance XIParamTy        DocNameI = ApiAnn +type instance XKindSig         DocNameI = ApiAnn  type instance XSpliceTy        DocNameI = Void       -- see `renameHsSpliceTy` -type instance XDocTy           DocNameI = NoExtField -type instance XBangTy          DocNameI = NoExtField -type instance XRecTy           DocNameI = NoExtField -type instance XExplicitListTy  DocNameI = NoExtField -type instance XExplicitTupleTy DocNameI = NoExtField -type instance XTyLit           DocNameI = NoExtField -type instance XWildCardTy      DocNameI = NoExtField +type instance XDocTy           DocNameI = ApiAnn +type instance XBangTy          DocNameI = ApiAnn +type instance XRecTy           DocNameI = ApiAnn +type instance XExplicitListTy  DocNameI = ApiAnn +type instance XExplicitTupleTy DocNameI = ApiAnn +type instance XTyLit           DocNameI = ApiAnn +type instance XWildCardTy      DocNameI = ApiAnn  type instance XXType           DocNameI = HsCoreTy  type instance XHsForAllVis        DocNameI = NoExtField @@ -766,6 +801,9 @@ type instance XXFamEqn       DocNameI _ = NoExtCon  type instance XCClsInstDecl DocNameI = NoExtField  type instance XCDerivDecl   DocNameI = NoExtField +type instance XStockStrategy    DocNameI = NoExtField +type instance XAnyClassStrategy DocNameI = NoExtField +type instance XNewtypeStrategy  DocNameI = NoExtField  type instance XViaStrategy  DocNameI = LHsSigType DocNameI  type instance XDataFamInstD DocNameI = NoExtField  type instance XTyFamInstD   DocNameI = NoExtField @@ -793,3 +831,9 @@ type instance XConDeclField  DocNameI = NoExtField  type instance XXConDeclField DocNameI = NoExtCon  type instance XXPat DocNameI = NoExtCon + +type instance XCInjectivityAnn DocNameI = NoExtField + +type instance XCFunDep DocNameI = NoExtField + +type instance XCTyFamInstDecl DocNameI = NoExtField  | 
