From 6414b46e1ac8b63cad20d662311788a80e3b29bb Mon Sep 17 00:00:00 2001 From: Shayan-Najd Date: Fri, 23 Nov 2018 01:38:49 +0100 Subject: [TTG: Handling Source Locations] Foundation and Pat Trac Issues #15495 This patch removes the ping-pong style from HsPat (only, for now), using the plan laid out at https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution A). - the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced - some instances of `HasSrcSpan` are introduced - some constructors `L` are replaced with `cL` - some patterns `L` are replaced with `dL->L` view pattern - some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`) --- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 78 +++++++++++++--------- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 + haddock-api/src/Haddock/Backends/Xhtml.hs | 4 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 3 +- haddock-api/src/Haddock/GhcUtils.hs | 6 +- haddock-api/src/Haddock/Interface/Rename.hs | 1 + haddock-api/src/Haddock/Types.hs | 17 +++++ 7 files changed, 75 insertions(+), 36 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index 0ecf7109..a9ffc36e 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Haddock.Backends.Hyperlinker.Ast (enrich) where @@ -80,13 +81,16 @@ variables = everythingInRenamedSource (var `Syb.combine` rec) where var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) -> + (Just ((GHC.dL->GHC.L sspan (GHC.HsVar _ name)) + :: GHC.LHsExpr GHC.GhcRn)) -> pure (sspan, RtkVar (GHC.unLoc name)) - (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) -> + (Just (GHC.dL->GHC.L _ (GHC.RecordCon _ + (GHC.dL->GHC.L sspan name) _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of - Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) -> + Just (GHC.HsRecField (GHC.dL->GHC.L sspan name) + (_ :: GHC.LHsExpr GHC.GhcRn) _) -> pure (sspan, RtkVar name) _ -> empty @@ -96,9 +100,11 @@ types = everythingInRenamedSource ty where ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)] ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.dL->GHC.L sspan (GHC.HsTyVar _ _ name)) + :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) - (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) -> + (Just ((GHC.dL->GHC.L sspan (GHC.HsOpTy _ l name r)) + :: GHC.LHsType GHC.GhcRn)) -> (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r) _ -> empty @@ -113,30 +119,38 @@ binds = everythingInRenamedSource (fun `Syb.combine` pat `Syb.combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) -> + (Just (GHC.FunBind _ (GHC.dL->GHC.L sspan name) _ _ _ + :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) - (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) -> - pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args + (Just (GHC.PatSynBind _ + (GHC.PSB _ (GHC.dL->GHC.L sspan name) args _ _))) -> + pure (sspan, RtkBind name) + ++ everythingInRenamedSource patsyn_binds args _ -> empty patsyn_binds term = case cast term of - (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name) + (Just (GHC.L sspan (name :: GHC.Name))) -> + pure (sspan, RtkVar name) _ -> empty pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) -> + (Just ((GHC.dL->GHC.L sspan (GHC.VarPat _ name)) + :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> + (Just (GHC.dL->GHC.L _ + (GHC.ConPatIn (GHC.dL->GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs - (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) -> + (Just (GHC.dL->GHC.L _ (GHC.AsPat _ (GHC.dL->GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty rec term = case cast term of - (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) -> + (Just (GHC.HsRecField (GHC.dL->GHC.L sspan name) + (_ :: GHC.LPat GHC.GhcRn) _)) -> pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> + (Just ((GHC.dL->GHC.L sspan (GHC.UserTyVar _ name)) + :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) - (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) -> + (Just (GHC.dL->GHC.L _ (GHC.KindedTyVar _ (GHC.dL->GHC.L sspan name) _))) -> pure (sspan, RtkBind name) _ -> empty @@ -149,7 +163,7 @@ decls (group, _, _, _) = concatMap ($ group) , everythingInRenamedSource (con `Syb.combine` ins) ] where - typ (GHC.L _ t) = case t of + typ (GHC.dL->GHC.L _ t) = case t of GHC.DataDecl { tcdLName = name } -> pure . decl $ name GHC.SynDecl _ name _ _ _ -> pure . decl $ name GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam @@ -159,9 +173,10 @@ decls (group, _, _, _) = concatMap ($ group) ++ concatMap tyfam tcdATs GHC.XTyClDecl {} -> GHC.panic "haddock:decls" fun term = case cast term of - (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) + (Just (GHC.FunBind _ (GHC.dL->GHC.L sspan name) _ _ _ + :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) - (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _))) + (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.dL->GHC.L sspan name) _ _ _))) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of @@ -182,18 +197,20 @@ decls (group, _, _, _) = concatMap ($ group) Nothing -> empty fix term = case cast term of Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn) - -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names + -> map (\(GHC.dL->GHC.L sspan x) -> (sspan, RtkVar x)) names Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn) -> GHC.panic "haddock:decls" Nothing -> empty - tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] - tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" - sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names - sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names - sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names + tyfam (GHC.dL->GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName] + tyfam (GHC.dL->GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels" + tyfam _ = GHC.panic "tyfam: Impossible Match" + + sig (GHC.dL->GHC.L _ (GHC.TypeSig _ names _)) = map decl names + sig (GHC.dL->GHC.L _ (GHC.PatSynSig _ names _)) = map decl names + sig (GHC.dL->GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names sig _ = [] - decl (GHC.L sspan name) = (sspan, RtkDecl name) - tyref (GHC.L sspan name) = (sspan, RtkType name) + decl (GHC.dL->GHC.L sspan name) = (sspan, RtkDecl name) + tyref (GHC.dL->GHC.L sspan name) = (sspan, RtkType name) -- | Obtain details map for import declarations. -- @@ -204,16 +221,17 @@ imports src@(_, imps, _, _) = everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v + (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var + $ GHC.ieLWrappedName v (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith _ t _ vs _fls)) -> [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs (Just (GHC.IEModuleContents _ m)) -> pure $ modu m _ -> empty - typ (GHC.L sspan name) = (sspan, RtkType name) - var (GHC.L sspan name) = (sspan, RtkVar name) - modu (GHC.L sspan name) = (sspan, RtkModule name) + typ (GHC.dL->GHC.L sspan name) = (sspan, RtkType name) + var (GHC.dL->GHC.L sspan name) = (sspan, RtkVar name) + modu (GHC.dL->GHC.L sspan name) = (sspan, RtkModule name) imp idecl | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl)) | otherwise = Nothing diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 22cb247f..b66116bb 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs index db29c7cf..da8f7a53 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -397,11 +397,11 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d where names = exportName item ++ exportSubs item - exportSubs :: ExportItem name -> [IdP name] + exportSubs :: ExportItem DocNameI -> [IdP DocNameI] exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs exportSubs _ = [] - exportName :: ExportItem name -> [IdP name] + exportName :: ExportItem DocNameI -> [IdP DocNameI] exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl) exportName ExportNoDecl { expItemName } = [expItemName] exportName _ = [] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index ec8de12a..395c0837 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TransformListComp #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Backends.Html.Decl @@ -1215,4 +1217,3 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_tylit :: HsTyLit -> Html ppr_tylit (HsNumTy _ n) = toHtml (show n) ppr_tylit (HsStrTy _ s) = toHtml (show s) - diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index e7d80969..cfb91f93 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -48,7 +49,8 @@ isConSym :: OccName -> Bool isConSym = isLexConSym . occNameFS -getMainDeclBinder :: HsDecl name -> [IdP name] +getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + HsDecl p -> [IdP p] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders d of @@ -434,5 +436,3 @@ setStubDir f d = d{ stubDir = Just f -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f - - diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 42281470..c6160b2b 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index ea8ffe5f..7b3c90a2 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -742,3 +743,19 @@ type instance XHsWC DocNameI _ = NoExt type instance XHsQTvs DocNameI = NoExt type instance XConDeclField DocNameI = NoExt +type instance XXPat DocNameI = Located (Pat DocNameI) + +type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI +instance HasSrcSpan (LPat DocNameI) where + -- NB: The following chooses the behaviour of the outer location + -- wrapper replacing the inner ones. + composeSrcSpan (L sp p) = if sp == noSrcSpan + then p + else XPat (L sp (stripSrcSpanPat p)) + -- NB: The following only returns the top-level location, if any. + decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) + decomposeSrcSpan p = L noSrcSpan p + +stripSrcSpanPat :: LPat DocNameI -> Pat DocNameI +stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p +stripSrcSpanPat p = p -- cgit v1.2.3