diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2021-02-21 21:23:40 +0000 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-20 07:48:38 -0400 |
| commit | 95275a5f25a2e70b71240d4756109180486af1b1 (patch) | |
| tree | eb4801bb0e00098b8b9d513479de4fbbd779ddac /compiler | |
| parent | f940fd466a86c2f8e93237b36835797be3f3c898 (diff) | |
| download | haskell-95275a5f25a2e70b71240d4756109180486af1b1.tar.gz | |
GHC Exactprint main commit
Metric Increase:
T10370
parsing001
Updates haddock submodule
Diffstat (limited to 'compiler')
103 files changed, 6694 insertions, 4762 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 7e6d8349b6..9d2d6fb65f 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -283,10 +283,7 @@ module GHC ( parser, -- * API Annotations - ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey, - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments, getAndRemoveAnnotationComments, - unicodeAnn, + ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), -- * Miscellaneous --sessionHscEnv, diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs index 7077b6f489..a1ddbd44f1 100644 --- a/compiler/GHC/Data/BooleanFormula.hs +++ b/compiler/GHC/Data/BooleanFormula.hs @@ -24,6 +24,7 @@ import Data.Data import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Binary +import GHC.Parser.Annotation ( LocatedL ) import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set @@ -32,7 +33,7 @@ import GHC.Types.Unique.Set -- Boolean formula type and smart constructors ---------------------------------------------------------------------- -type LBooleanFormula a = Located (BooleanFormula a) +type LBooleanFormula a = LocatedL (BooleanFormula a) data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] | Parens (LBooleanFormula a) diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 5974cded53..daf53a502f 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -764,6 +764,7 @@ summariseRequirement pn mod_name = do ms_textual_imps = extra_sig_imports, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule { + hsmodAnn = noAnn, hsmodLayout = NoLayoutInfo, hsmodName = Just (L loc mod_name), hsmodExports = Nothing, @@ -773,7 +774,7 @@ summariseRequirement pn mod_name = do hsmodHaddockModHeader = Nothing }), hpm_src_files = [], - hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] + hpm_annotations = ApiAnns [] }), ms_hspp_file = "", -- none, it came inline ms_hspp_opts = dflags, @@ -884,7 +885,7 @@ hsModuleToModSummary pn hsc_src modname ms_parsed_mod = Just (HsParsedModule { hpm_module = hsmod, hpm_src_files = [], -- TODO if we preprocessed it - hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] -- BOGUS + hpm_annotations = ApiAnns [] -- BOGUS }), ms_hs_date = time, ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 393c31fa0b..a910cdf23f 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -141,7 +141,6 @@ import GHC.Core.FamInstEnv import GHC.CoreToStg.Prep import GHC.CoreToStg ( coreToStg ) -import GHC.Parser.Annotation import GHC.Parser.Errors import GHC.Parser.Errors.Ppr import GHC.Parser @@ -216,14 +215,13 @@ import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) import Data.Data hiding (Fixity, TyCon) -import Data.Maybe ( fromJust ) +import Data.Maybe ( fromJust, fromMaybe ) import Data.List ( nub, isPrefixOf, partition ) import Control.Monad import Data.IORef import System.FilePath as FilePath import System.Directory import System.IO (fixIO) -import qualified Data.Map as M import qualified Data.Set as S import Data.Set (Set) import Data.Functor @@ -353,7 +351,7 @@ ioMsgMaybe' ioA = do -- ----------------------------------------------------------------------------- -- | Lookup things in the compiler's environment -hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] +hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name] hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do { hsc_env <- getHscEnv @@ -431,7 +429,9 @@ hscParse' mod_summary liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" - FormatHaskell (showAstData NoBlankSrcSpan rdr_module) + FormatHaskell (showAstData NoBlankSrcSpan + NoBlankApiAnnotations + rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module) when (not $ isEmptyBag errs) $ throwErrors errs @@ -463,10 +463,7 @@ hscParse' mod_summary srcs2 <- liftIO $ filterM doesFileExist srcs1 let api_anns = ApiAnns { - apiAnnItems = M.fromListWith (++) $ annotations pst, - apiAnnEofPos = eof_pos pst, - apiAnnComments = M.fromList (annotations_comments pst), - apiAnnRogueComments = comment_q pst + apiAnnRogueComments = (fromMaybe [] (header_comments pst)) ++ comment_q pst } res = HsParsedModule { hpm_module = rdr_module, @@ -490,7 +487,7 @@ extract_renamed_stuff mod_summary tc_result = do dflags <- getDynFlags logger <- getLogger liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer" - FormatHaskell (showAstData NoBlankSrcSpan rn_info) + FormatHaskell (showAstData NoBlankSrcSpan NoBlankApiAnnotations rn_info) -- Create HIE files when (gopt Opt_WriteHie dflags) $ do @@ -1158,9 +1155,9 @@ hscCheckSafeImports tcg_env = do warns rules = listToBag $ map warnRules rules - warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> MsgEnvelope DecoratedSDoc + warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc warnRules (L loc (HsRule { rd_name = n })) = - mkPlainWarnMsg loc $ + mkPlainWarnMsg (locA loc) $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -2021,7 +2018,7 @@ hscParseStmtWithLocation source linenumber stmt = hscParseType :: String -> Hsc (LHsType GhcPs) hscParseType = hscParseThing parseType -hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName) hscParseIdentifier hsc_env str = runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str @@ -2049,7 +2046,7 @@ hscParseThingWithLocation source linenumber parser str = do liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr thing) liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" - FormatHaskell (showAstData NoBlankSrcSpan thing) + FormatHaskell (showAstData NoBlankSrcSpan NoBlankApiAnnotations thing) return thing diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs index fbaf145fa2..186992065f 100644 --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -1,6 +1,7 @@ -- | Printing related functions that depend on session state (DynFlags) module GHC.Driver.Ppr ( showSDoc + , showSDocUnsafe , showSDocForUser , showSDocDebug , showSDocDump @@ -40,6 +41,9 @@ import Control.Monad.IO.Class showSDoc :: DynFlags -> SDoc -> String showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc +showSDocUnsafe :: SDoc -> String +showSDocUnsafe sdoc = renderWithContext defaultSDocContext sdoc + showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 8508120d6c..95cf14a616 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -30,9 +30,10 @@ module GHC.Hs ( module GHC.Hs.Utils, module GHC.Hs.Doc, module GHC.Hs.Extension, + module GHC.Parser.Annotation, Fixity, - HsModule(..), + HsModule(..), AnnsModule(..), HsParsedModule(..) ) where @@ -46,6 +47,7 @@ import GHC.Hs.ImpExp import GHC.Hs.Lit import Language.Haskell.Syntax import GHC.Hs.Extension +import GHC.Parser.Annotation import GHC.Hs.Pat import GHC.Hs.Type import GHC.Hs.Utils @@ -53,7 +55,6 @@ import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances -- others: -import GHC.Parser.Annotation ( ApiAnns ) import GHC.Utils.Outputable import GHC.Types.Fixity ( Fixity ) import GHC.Types.SrcLoc @@ -68,13 +69,14 @@ import Data.Data hiding ( Fixity ) -- All we actually declare here is the top-level structure for a module. data HsModule = HsModule { + hsmodAnn :: ApiAnn' AnnsModule, hsmodLayout :: LayoutInfo, -- ^ Layout info for the module. -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. hsmodName :: Maybe (Located ModuleName), -- ^ @Nothing@: \"module X where\" is omitted (in which case the next -- field is Nothing too) - hsmodExports :: Maybe (Located [LIE GhcPs]), + hsmodExports :: Maybe (LocatedL [LIE GhcPs]), -- ^ Export list -- -- - @Nothing@: export list omitted, so export everything @@ -94,7 +96,7 @@ data HsModule -- downstream. hsmodDecls :: [LHsDecl GhcPs], -- ^ Type, class, value, and interface signature decls - hsmodDeprecMessage :: Maybe (Located WarningTxt), + hsmodDeprecMessage :: Maybe (LocatedP WarningTxt), -- ^ reason\/explanation for warning/deprecation of this module -- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' @@ -122,13 +124,19 @@ data HsModule deriving instance Data HsModule +data AnnsModule + = AnnsModule { + am_main :: [AddApiAnn], + am_decls :: AnnList + } deriving (Data, Eq) + instance Outputable HsModule where - ppr (HsModule _ Nothing _ imports decls _ mbDoc) + ppr (HsModule _ _ Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule _ (Just name) exports imports decls deprec mbDoc) + ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc) = vcat [ pp_mb mbDoc, case exports of diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 91b5dd7724..34fc3dc3bb 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -31,9 +31,11 @@ import GHC.Prelude import Language.Haskell.Syntax.Binds import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind ) +import {-# SOURCE #-} GHC.Hs.Pat (pprLPat ) import Language.Haskell.Syntax.Extension import GHC.Hs.Extension +import GHC.Parser.Annotation import GHC.Hs.Type import GHC.Tc.Types.Evidence import GHC.Core.Type @@ -44,12 +46,16 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Data.Bag import GHC.Data.FastString import GHC.Data.BooleanFormula (LBooleanFormula) +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Id import GHC.Utils.Outputable import GHC.Utils.Panic import Data.List (sortBy) import Data.Function +import Data.Data (Data) {- ************************************************************************ @@ -64,8 +70,8 @@ Global bindings (where clauses) -- the ...LR datatypes are parametrized by two id types, -- one for the left and one for the right. -type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField -type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = ApiAnn' AnnList +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = ApiAnn' AnnList type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon @@ -78,7 +84,7 @@ data NHsValBindsLR idL [(RecFlag, LHsBinds idL)] [LSig GhcRn] -type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExtField +type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey type instance XXValBindsLR (GhcPass pL) (GhcPass pR) = NHsValBindsLR (GhcPass pL) @@ -88,7 +94,7 @@ type instance XFunBind (GhcPass pL) GhcPs = NoExtField type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables type instance XFunBind (GhcPass pL) GhcTc = HsWrapper -- See comments on FunBind.fun_ext -type instance XPatBind GhcPs (GhcPass pR) = NoExtField +type instance XPatBind GhcPs (GhcPass pR) = ApiAnn type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs @@ -100,7 +106,7 @@ type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon type instance XABE (GhcPass p) = NoExtField type instance XXABExport (GhcPass p) = NoExtCon -type instance XPSB (GhcPass idL) GhcPs = NoExtField +type instance XPSB (GhcPass idL) GhcPs = ApiAnn type instance XPSB (GhcPass idL) GhcRn = NameSet type instance XPSB (GhcPass idL) GhcTc = NameSet @@ -381,8 +387,8 @@ pprLHsBindsForUser binds sigs where decls :: [(SrcSpan, SDoc)] - decls = [(loc, ppr sig) | L loc sig <- sigs] ++ - [(loc, ppr bind) | L loc bind <- bagToList binds] + decls = [(locA loc, ppr sig) | L loc sig <- sigs] ++ + [(locA loc, ppr bind) | L loc bind <- bagToList binds] sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls @@ -410,7 +416,7 @@ isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds noExtField emptyBag [] +emptyValBindsIn = ValBinds NoAnnSortKey emptyBag [] emptyValBindsOut = XValBindsLR (NValBinds [] []) emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR @@ -423,7 +429,7 @@ isEmptyLHsBinds = isEmptyBag plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2) + = ValBinds NoAnnSortKey (ds1 `unionBags` ds2) (sigs1 ++ sigs2) plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) (XValBindsLR (NValBinds ds2 sigs2)) = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) @@ -477,21 +483,35 @@ instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where , nest 2 (pprTcSpecPrags prags) , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ] -instance (OutputableBndrId l, OutputableBndrId r, - Outputable (XXPatSynBind (GhcPass l) (GhcPass r))) +instance (OutputableBndrId l, OutputableBndrId r) => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) = ppr_lhs <+> ppr_rhs where ppr_lhs = text "pattern" <+> ppr_details - ppr_simple syntax = syntax <+> ppr pat + ppr_simple syntax = syntax <+> pprLPat pat ppr_details = case details of - InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] - PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr vs) + InfixCon v1 v2 -> hsep [ppr_v v1, pprInfixOcc psyn, ppr_v v2] + where + ppr_v v = case ghcPass @r of + GhcPs -> ppr v + GhcRn -> ppr v + GhcTc -> ppr v + PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr_v vs) + where + ppr_v v = case ghcPass @r of + GhcPs -> ppr v + GhcRn -> ppr v + GhcTc -> ppr v RecCon vs -> pprPrefixOcc psyn - <> braces (sep (punctuate comma (map ppr vs))) + <> braces (sep (punctuate comma (map ppr_v vs))) + where + ppr_v v = case ghcPass @r of + GhcPs -> ppr v + GhcRn -> ppr v + GhcTc -> ppr v ppr_rhs = case dir of Unidirectional -> ppr_simple (text "<-") @@ -533,7 +553,7 @@ isEmptyIPBindsPR (IPBinds _ is) = null is isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -type instance XCIPBind (GhcPass p) = NoExtField +type instance XCIPBind (GhcPass p) = ApiAnn type instance XXIPBind (GhcPass p) = NoExtCon instance OutputableBndrId p @@ -555,26 +575,35 @@ instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where ************************************************************************ -} -type instance XTypeSig (GhcPass p) = NoExtField -type instance XPatSynSig (GhcPass p) = NoExtField -type instance XClassOpSig (GhcPass p) = NoExtField -type instance XIdSig (GhcPass p) = NoExtField -type instance XFixSig (GhcPass p) = NoExtField -type instance XInlineSig (GhcPass p) = NoExtField -type instance XSpecSig (GhcPass p) = NoExtField -type instance XSpecInstSig (GhcPass p) = NoExtField -type instance XMinimalSig (GhcPass p) = NoExtField -type instance XSCCFunSig (GhcPass p) = NoExtField -type instance XCompleteMatchSig (GhcPass p) = NoExtField +type instance XTypeSig (GhcPass p) = ApiAnn' AnnSig +type instance XPatSynSig (GhcPass p) = ApiAnn' AnnSig +type instance XClassOpSig (GhcPass p) = ApiAnn' AnnSig +type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated +type instance XFixSig (GhcPass p) = ApiAnn +type instance XInlineSig (GhcPass p) = ApiAnn +type instance XSpecSig (GhcPass p) = ApiAnn +type instance XSpecInstSig (GhcPass p) = ApiAnn +type instance XMinimalSig (GhcPass p) = ApiAnn +type instance XSCCFunSig (GhcPass p) = ApiAnn +type instance XCompleteMatchSig (GhcPass p) = ApiAnn + type instance XXSig (GhcPass p) = NoExtCon type instance XFixitySig (GhcPass p) = NoExtField type instance XXFixitySig (GhcPass p) = NoExtCon +data AnnSig + = AnnSig { + asDcolon :: AddApiAnn, -- Not an AnnAnchor to capture unicode option + asRest :: [AddApiAnn] + } deriving Data + + instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where ppr sig = ppr_sig sig -ppr_sig :: (OutputableBndrId p) => Sig (GhcPass p) -> SDoc +ppr_sig :: forall p. OutputableBndrId p + => Sig (GhcPass p) -> SDoc ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) @@ -598,13 +627,22 @@ ppr_sig (MinimalSig _ src bf) ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) ppr_sig (SCCFunSig _ src fn mlabel) - = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) + = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel ) + where + ppr_fn = case ghcPass @p of + GhcPs -> ppr fn + GhcRn -> ppr fn + GhcTc -> ppr fn ppr_sig (CompleteMatchSig _ src cs mty) = pragSrcBrackets src "{-# COMPLETE" - ((hsep (punctuate comma (map ppr (unLoc cs)))) + ((hsep (punctuate comma (map ppr_n (unLoc cs)))) <+> opt_sig) where - opt_sig = maybe empty (\t -> dcolon <+> ppr t) mty + opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty + ppr_n n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where @@ -641,5 +679,29 @@ instance Outputable TcSpecPrag where = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl pprMinimalSig :: (OutputableBndr name) - => LBooleanFormula (Located name) -> SDoc + => LBooleanFormula (GenLocated l name) -> SDoc pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA +type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA +type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA + +-- For CompleteMatchSig +type instance Anno [LocatedN RdrName] = SrcSpan +type instance Anno [LocatedN Name] = SrcSpan +type instance Anno [LocatedN Id] = SrcSpan + +type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA + +type instance Anno StringLiteral = SrcSpan +type instance Anno (LocatedN RdrName) = SrcSpan +type instance Anno (LocatedN Name) = SrcSpan +type instance Anno (LocatedN Id) = SrcSpan diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index cfafa76733..7592926f07 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -45,6 +45,7 @@ module GHC.Hs.Decls ( tyClDeclLName, tyClDeclTyVars, hsDeclHasCusk, famResultKindSignature, FamilyDecl(..), LFamilyDecl, + FunDep(..), -- ** Instance declarations InstDecl(..), LInstDecl, FamilyInfo(..), @@ -60,8 +61,10 @@ module GHC.Hs.Decls ( -- ** Deriving strategies DerivStrategy(..), LDerivStrategy, derivStrategyName, foldDerivStrategy, mapDerivStrategy, + XViaStrategyPs(..), -- ** @RULE@ declarations LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), + HsRuleAnn(..), RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, flattenRuleDecls, pprFullRuleName, @@ -113,20 +116,22 @@ import GHC.Types.Basic import GHC.Core.Coercion import Language.Haskell.Syntax.Extension import GHC.Hs.Extension +import GHC.Parser.Annotation import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Fixity -- others: -import GHC.Core.Class import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Core.Type +import GHC.Types.ForeignCall import GHC.Data.Bag import GHC.Data.Maybe +import Data.Data (Data) {- ************************************************************************ @@ -163,7 +168,7 @@ type instance XXHsDecl (GhcPass _) = NoExtCon partitionBindsAndSigs :: [LHsDecl GhcPs] -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], - [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) partitionBindsAndSigs = go where go [] = (emptyBag, [], [], [], [], []) @@ -322,30 +327,37 @@ instance OutputableBndrId p type instance XFamDecl (GhcPass _) = NoExtField -type instance XSynDecl GhcPs = NoExtField +type instance XSynDecl GhcPs = ApiAnn type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs -type instance XDataDecl GhcPs = NoExtField +type instance XDataDecl GhcPs = ApiAnn -- AZ: used? type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn -type instance XClassDecl GhcPs = LayoutInfo -- See Note [Class LayoutInfo] +type instance XClassDecl GhcPs = (ApiAnn, AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] + -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs type instance XXTyClDecl (GhcPass _) = NoExtCon +type instance XCTyFamInstDecl (GhcPass _) = ApiAnn +type instance XXTyFamInstDecl (GhcPass _) = NoExtCon + -- Dealing with names -tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p) +tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyFamInstDecl (GhcPass p) -> IdP (GhcPass p) tyFamInstDeclName = unLoc . tyFamInstDeclLName -tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p)) +tyFamInstDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p)) tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = ln }}) = ln -tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p)) +tyClDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p)) tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd tyClDeclLName (SynDecl { tcdLName = ln }) = ln tyClDeclLName (DataDecl { tcdLName = ln }) = ln @@ -353,7 +365,8 @@ tyClDeclLName (ClassDecl { tcdLName = ln }) = ln -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it -- needs to be polymorphic in the pass -tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p) +tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => TyClDecl (GhcPass p) -> IdP (GhcPass p) tcdName = unLoc . tyClDeclLName -- | Does this declaration have a complete, user-supplied kind signature? @@ -398,7 +411,7 @@ instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where | otherwise -- Laid out = vcat [ top_matter <+> text "where" - , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ + , nest 2 $ pprDeclList (map (ppr . unLoc) ats ++ map (pprTyFamDefltDecl . unLoc) at_defs ++ pprLHsBindsForUser methods sigs) ] where @@ -421,7 +434,7 @@ instance OutputableBndrId p ppr instds pp_vanilla_decl_head :: (OutputableBndrId p) - => Located (IdP (GhcPass p)) + => XRec (GhcPass p) (IdP (GhcPass p)) -> LHsQTyVars (GhcPass p) -> LexicalFixity -> Maybe (LHsContext (GhcPass p)) @@ -449,6 +462,19 @@ pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) = ppr nd +instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where + ppr = pprFunDep + +type instance XCFunDep (GhcPass _) = ApiAnn +type instance XXFunDep (GhcPass _) = NoExtCon + +pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) + +pprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc +pprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs] + {- ********************************************************************* * * TyClGroup @@ -473,13 +499,13 @@ type instance XCKindSig (GhcPass _) = NoExtField type instance XTyVarSig (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = NoExtCon -type instance XCFamilyDecl (GhcPass _) = NoExtField +type instance XCFamilyDecl (GhcPass _) = ApiAnn type instance XXFamilyDecl (GhcPass _) = NoExtCon ------------- Functions over FamilyDecls ----------- -familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p)) +familyDeclLName :: FamilyDecl (GhcPass p) -> XRec (GhcPass p) (IdP (GhcPass p)) familyDeclLName (FamilyDecl { fdLName = n }) = n familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p) @@ -500,41 +526,41 @@ resultVariableName _ = Nothing ------------- Pretty printing FamilyDecls ----------- +type instance XCInjectivityAnn (GhcPass _) = ApiAnn +type instance XXInjectivityAnn (GhcPass _) = NoExtCon + instance OutputableBndrId p => Outputable (FamilyDecl (GhcPass p)) where - ppr = pprFamilyDecl TopLevel - -pprFamilyDecl :: (OutputableBndrId p) - => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc -pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = L _ result - , fdInjectivityAnn = mb_inj }) - = vcat [ pprFlavour info <+> pp_top_level <+> - pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> - pp_kind <+> pp_inj <+> pp_where - , nest 2 $ pp_eqns ] - where - pp_top_level = case top_level of - TopLevel -> text "family" - NotTopLevel -> empty - - pp_kind = case result of - NoSig _ -> empty - KindSig _ kind -> dcolon <+> ppr kind - TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr - pp_inj = case mb_inj of - Just (L _ (InjectivityAnn lhs rhs)) -> - hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] - Nothing -> empty - (pp_where, pp_eqns) = case info of - ClosedTypeFamily mb_eqns -> - ( text "where" - , case mb_eqns of - Nothing -> text ".." - Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) - _ -> (empty, empty) + ppr (FamilyDecl { fdInfo = info, fdLName = ltycon + , fdTopLevel = top_level + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L _ result + , fdInjectivityAnn = mb_inj }) + = vcat [ pprFlavour info <+> pp_top_level <+> + pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> + pp_kind <+> pp_inj <+> pp_where + , nest 2 $ pp_eqns ] + where + pp_top_level = case top_level of + TopLevel -> text "family" + NotTopLevel -> empty + + pp_kind = case result of + NoSig _ -> empty + KindSig _ kind -> dcolon <+> ppr kind + TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr + pp_inj = case mb_inj of + Just (L _ (InjectivityAnn _ lhs rhs)) -> + hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + Nothing -> empty + (pp_where, pp_eqns) = case info of + ClosedTypeFamily mb_eqns -> + ( text "where" + , case mb_eqns of + Nothing -> text ".." + Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) + _ -> (empty, empty) @@ -544,11 +570,10 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon * * ********************************************************************* -} -type instance XCHsDataDefn (GhcPass _) = NoExtField - +type instance XCHsDataDefn (GhcPass _) = ApiAnn type instance XXHsDataDefn (GhcPass _) = NoExtCon -type instance XCHsDerivingClause (GhcPass _) = NoExtField +type instance XCHsDerivingClause (GhcPass _) = ApiAnn type instance XXHsDerivingClause (GhcPass _) = NoExtCon instance OutputableBndrId p @@ -575,25 +600,28 @@ instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where ppr (DctSingle _ ty) = ppr ty ppr (DctMulti _ tys) = parens (interpp'SP tys) -type instance XStandaloneKindSig (GhcPass p) = NoExtField +type instance XStandaloneKindSig GhcPs = ApiAnn +type instance XStandaloneKindSig GhcRn = NoExtField +type instance XStandaloneKindSig GhcTc = NoExtField + type instance XXStandaloneKindSig (GhcPass p) = NoExtCon standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT (GhcPass _) = NoExtField -type instance XConDeclH98 (GhcPass _) = NoExtField +type instance XConDeclGADT (GhcPass _) = ApiAnn +type instance XConDeclH98 (GhcPass _) = ApiAnn type instance XXConDecl (GhcPass _) = NoExtCon -getConNames :: ConDecl GhcRn -> [Located Name] +getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -- | Return @'Just' fields@ if a data constructor declaration uses record -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. -- Otherwise, return 'Nothing'. -getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (Located [LConDeclField GhcRn]) +getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn]) getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of PrefixCon{} -> Nothing RecCon flds -> Just flds @@ -628,7 +656,7 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context pp_sig = case mb_sig of Nothing -> empty Just kind -> dcolon <+> ppr kind - pp_derivings (L _ ds) = vcat (map ppr ds) + pp_derivings ds = vcat (map ppr ds) instance OutputableBndrId p => Outputable (HsDataDefn (GhcPass p)) where @@ -661,7 +689,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con , con_args = args , con_doc = doc }) = sep [ ppr_mbDoc doc - , pprHsForAll (mkHsForAllInvisTele ex_tvs) mcxt + , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt , ppr_details args ] where -- In ppr_details: let's not print the multiplicities (they are always 1, by @@ -684,11 +712,10 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs get_args (PrefixConGADT args) = map ppr args get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)] - ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) ppr_arrow_chain [] = empty -ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc +ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) {- @@ -699,19 +726,31 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) ************************************************************************ -} -type instance XCFamEqn (GhcPass _) r = NoExtField +type instance XCFamEqn (GhcPass _) r = ApiAnn type instance XXFamEqn (GhcPass _) r = NoExtCon +type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA + ----------------- Class instances ------------- -type instance XCClsInstDecl (GhcPass _) = NoExtField +type instance XCClsInstDecl GhcPs = (ApiAnn, AnnSortKey) -- TODO:AZ:tidy up +type instance XCClsInstDecl GhcRn = NoExtField +type instance XCClsInstDecl GhcTc = NoExtField + type instance XXClsInstDecl (GhcPass _) = NoExtCon ----------------- Instances of all kinds ------------- type instance XClsInstD (GhcPass _) = NoExtField -type instance XDataFamInstD (GhcPass _) = NoExtField -type instance XTyFamInstD (GhcPass _) = NoExtField + +type instance XDataFamInstD GhcPs = ApiAnn +type instance XDataFamInstD GhcRn = NoExtField +type instance XDataFamInstD GhcTc = NoExtField + +type instance XTyFamInstD GhcPs = NoExtField +type instance XTyFamInstD GhcRn = NoExtField +type instance XTyFamInstD GhcTc = NoExtField + type instance XXInstDecl (GhcPass _) = NoExtCon instance OutputableBndrId p @@ -754,8 +793,8 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = , feqn_rhs = defn })}) = pp_data_defn pp_hdr defn where - pp_hdr ctxt = ppr_instance_keyword top_lvl - <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt + pp_hdr mctxt = ppr_instance_keyword top_lvl + <+> pprHsFamInstLHS tycon bndrs pats fixity mctxt -- pp_data_defn pretty-prints the kind sig. See #14817. pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc @@ -811,7 +850,7 @@ ppDerivStrategy mb = Nothing -> empty Just (L _ ds) -> ppr ds -ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc +ppOverlapPragma :: Maybe (LocatedP OverlapMode) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty @@ -850,9 +889,11 @@ instDeclDataFamInsts inst_decls ************************************************************************ -} -type instance XCDerivDecl (GhcPass _) = NoExtField +type instance XCDerivDecl (GhcPass _) = ApiAnn type instance XXDerivDecl (GhcPass _) = NoExtCon +type instance Anno OverlapMode = SrcSpanAnnP + instance OutputableBndrId p => Outputable (DerivDecl (GhcPass p)) where ppr (DerivDecl { deriv_type = ty @@ -872,26 +913,44 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XViaStrategy GhcPs = LHsSigType GhcPs +type instance XStockStrategy GhcPs = ApiAnn +type instance XStockStrategy GhcRn = NoExtField +type instance XStockStrategy GhcTc = NoExtField + +type instance XAnyClassStrategy GhcPs = ApiAnn +type instance XAnyClassStrategy GhcRn = NoExtField +type instance XAnyClassStrategy GhcTc = NoExtField + +type instance XNewtypeStrategy GhcPs = ApiAnn +type instance XNewtypeStrategy GhcRn = NoExtField +type instance XNewtypeStrategy GhcTc = NoExtField + +type instance XViaStrategy GhcPs = XViaStrategyPs type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type +data XViaStrategyPs = XViaStrategyPs ApiAnn (LHsSigType GhcPs) + instance OutputableBndrId p => Outputable (DerivStrategy (GhcPass p)) where - ppr StockStrategy = text "stock" - ppr AnyclassStrategy = text "anyclass" - ppr NewtypeStrategy = text "newtype" - ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of - GhcPs -> ppr ty - GhcRn -> ppr ty - GhcTc -> ppr ty + ppr (StockStrategy _) = text "stock" + ppr (AnyclassStrategy _) = text "anyclass" + ppr (NewtypeStrategy _) = text "newtype" + ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of + GhcPs -> ppr ty + GhcRn -> ppr ty + GhcTc -> ppr ty + +instance Outputable XViaStrategyPs where + ppr (XViaStrategyPs _ t) = ppr t + -- | Eliminate a 'DerivStrategy'. foldDerivStrategy :: (p ~ GhcPass pass) => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r -foldDerivStrategy other _ StockStrategy = other -foldDerivStrategy other _ AnyclassStrategy = other -foldDerivStrategy other _ NewtypeStrategy = other +foldDerivStrategy other _ (StockStrategy _) = other +foldDerivStrategy other _ (AnyclassStrategy _) = other +foldDerivStrategy other _ (NewtypeStrategy _) = other foldDerivStrategy _ via (ViaStrategy t) = via t -- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise, @@ -909,7 +968,10 @@ mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds ************************************************************************ -} -type instance XCDefaultDecl (GhcPass _) = NoExtField +type instance XCDefaultDecl GhcPs = ApiAnn +type instance XCDefaultDecl GhcRn = NoExtField +type instance XCDefaultDecl GhcTc = NoExtField + type instance XXDefaultDecl (GhcPass _) = NoExtCon instance OutputableBndrId p @@ -925,11 +987,11 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XForeignImport GhcPs = NoExtField +type instance XForeignImport GhcPs = ApiAnn type instance XForeignImport GhcRn = NoExtField type instance XForeignImport GhcTc = Coercion -type instance XForeignExport GhcPs = NoExtField +type instance XForeignExport GhcPs = ApiAnn type instance XForeignExport GhcRn = NoExtField type instance XForeignExport GhcTc = Coercion @@ -952,20 +1014,36 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XCRuleDecls (GhcPass _) = NoExtField +type instance XCRuleDecls GhcPs = ApiAnn +type instance XCRuleDecls GhcRn = NoExtField +type instance XCRuleDecls GhcTc = NoExtField + type instance XXRuleDecls (GhcPass _) = NoExtCon -type instance XHsRule GhcPs = NoExtField +type instance XHsRule GhcPs = ApiAnn' HsRuleAnn type instance XHsRule GhcRn = HsRuleRn type instance XHsRule GhcTc = HsRuleRn type instance XXRuleDecl (GhcPass _) = NoExtCon +type instance Anno (SourceText, RuleName) = SrcSpan + +data HsRuleAnn + = HsRuleAnn + { ra_tyanns :: Maybe (AddApiAnn, AddApiAnn) + -- ^ The locations of 'forall' and '.' for forall'd type vars + -- Using AddApiAnn to capture possible unicode variants + , ra_tmanns :: Maybe (AddApiAnn, AddApiAnn) + -- ^ The locations of 'forall' and '.' for forall'd term vars + -- Using AddApiAnn to capture possible unicode variants + , ra_rest :: [AddApiAnn] + } deriving (Data, Eq) + flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -type instance XCRuleBndr (GhcPass _) = NoExtField -type instance XRuleBndrSig (GhcPass _) = NoExtField +type instance XCRuleBndr (GhcPass _) = ApiAnn +type instance XRuleBndrSig (GhcPass _) = ApiAnn type instance XXRuleBndr (GhcPass _) = NoExtCon instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where @@ -1003,20 +1081,23 @@ instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where ************************************************************************ -} -type instance XWarnings (GhcPass _) = NoExtField +type instance XWarnings GhcPs = ApiAnn +type instance XWarnings GhcRn = NoExtField +type instance XWarnings GhcTc = NoExtField + type instance XXWarnDecls (GhcPass _) = NoExtCon -type instance XWarning (GhcPass _) = NoExtField +type instance XWarning (GhcPass _) = ApiAnn type instance XXWarnDecl (GhcPass _) = NoExtCon -instance OutputableBndr (IdP (GhcPass p)) +instance OutputableBndrId p => Outputable (WarnDecls (GhcPass p)) where ppr (Warnings _ (SourceText src) decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" -instance OutputableBndr (IdP (GhcPass p)) +instance OutputableBndrId p => Outputable (WarnDecl (GhcPass p)) where ppr (Warning _ thing txt) = hsep ( punctuate comma (map ppr thing)) @@ -1030,14 +1111,14 @@ instance OutputableBndr (IdP (GhcPass p)) ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = NoExtField +type instance XHsAnnotation (GhcPass _) = ApiAnn' AnnPragma type instance XXAnnDecl (GhcPass _) = NoExtCon instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where ppr (HsAnnotation _ _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] -pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc +pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc pprAnnProvenance ModuleAnnProvenance = text "ANN module" pprAnnProvenance (ValueAnnProvenance (L _ name)) = text "ANN" <+> ppr name @@ -1052,9 +1133,14 @@ pprAnnProvenance (TypeAnnProvenance (L _ name)) ************************************************************************ -} -type instance XCRoleAnnotDecl (GhcPass _) = NoExtField +type instance XCRoleAnnotDecl GhcPs = ApiAnn +type instance XCRoleAnnotDecl GhcRn = NoExtField +type instance XCRoleAnnotDecl GhcTc = NoExtField + type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon +type instance Anno (Maybe Role) = SrcSpan + instance OutputableBndr (IdP (GhcPass p)) => Outputable (RoleAnnotDecl (GhcPass p)) where ppr (RoleAnnotDecl _ ltycon roles) @@ -1066,3 +1152,48 @@ instance OutputableBndr (IdP (GhcPass p)) roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p) roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (HsDecl (GhcPass _)) = SrcSpanAnnA +type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA +type instance Anno (FamilyResultSig (GhcPass p)) = SrcSpan +type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (InjectivityAnn (GhcPass p)) = SrcSpan +type instance Anno CType = SrcSpanAnnP +type instance Anno (HsDerivingClause (GhcPass p)) = SrcSpan +type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC +type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA +type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno Bool = SrcSpan +type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL +type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA +type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA +type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno DocDecl = SrcSpanAnnA +type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno OverlapMode = SrcSpanAnnP +type instance Anno (DerivStrategy (GhcPass p)) = SrcSpan +type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA +type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (SourceText, RuleName) = SrcSpan +type instance Anno (RuleBndr (GhcPass p)) = SrcSpan +type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA +type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA +type instance Anno (Maybe Role) = SrcSpan + diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 639c738b74..329b2d9308 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -13,6 +13,7 @@ module GHC.Hs.Dump ( -- * Dumping ASTs showAstData, BlankSrcSpan(..), + BlankApiAnnotations(..), ) where import GHC.Prelude @@ -34,27 +35,48 @@ import GHC.Utils.Outputable import Data.Data hiding (Fixity) import qualified Data.ByteString as B -data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan +data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan + deriving (Eq,Show) + +data BlankApiAnnotations = BlankApiAnnotations | NoBlankApiAnnotations deriving (Eq,Show) -- | Show a GHC syntax tree. This parameterised because it is also used for -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked -- out, to avoid comparing locations, only structure -showAstData :: Data a => BlankSrcSpan -> a -> SDoc -showAstData b a0 = blankLine $$ showAstData' a0 +showAstData :: Data a => BlankSrcSpan -> BlankApiAnnotations -> a -> SDoc +showAstData bs ba a0 = blankLine $$ showAstData' a0 where showAstData' :: Data a => a -> SDoc showAstData' = generic `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan + `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan + `extQ` annotation + `extQ` annotationModule + `extQ` annotationAddApiAnn + `extQ` annotationGrhsAnn + `extQ` annotationApiAnnHsCase + `extQ` annotationAnnList + `extQ` annotationApiAnnImportDecl + `extQ` annotationAnnParen + `extQ` annotationTrailingAnn + `extQ` addApiAnn `extQ` lit `extQ` litr `extQ` litt + `extQ` sourceText + `extQ` deltaPos + `extQ` annAnchor `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` fixity `ext2Q` located + `extQ` srcSpanAnnA + `extQ` srcSpanAnnL + `extQ` srcSpanAnnP + `extQ` srcSpanAnnC + `extQ` srcSpanAnnN where generic :: Data a => a -> SDoc generic t = parens $ text (showConstr (toConstr t)) @@ -65,8 +87,8 @@ showAstData b a0 = blankLine $$ showAstData' a0 fastString :: FastString -> SDoc fastString s = braces $ - text "FastString: " - <> text (normalize_newlines . show $ s) + text "FastString:" + <+> text (normalize_newlines . show $ s) bytestring :: B.ByteString -> SDoc bytestring = text . normalize_newlines . show @@ -106,43 +128,81 @@ showAstData b a0 = blankLine $$ showAstData' a0 , generic x , generic s ] + sourceText :: SourceText -> SDoc + sourceText NoSourceText = parens $ text "NoSourceText" + sourceText (SourceText src) = case bs of + NoBlankSrcSpan -> parens $ text "SourceText" <+> text src + BlankSrcSpanFile -> parens $ text "SourceText" <+> text src + _ -> parens $ text "SourceText" <+> text "blanked" + + annAnchor :: AnnAnchor -> SDoc + annAnchor (AR r) = parens $ text "AR" <+> realSrcSpan r + annAnchor (AD d) = parens $ text "AD" <+> deltaPos d + + deltaPos :: DeltaPos -> SDoc + deltaPos (DP l c) = parens $ text "DP" <+> ppr l <+> ppr c + name :: Name -> SDoc - name nm = braces $ text "Name: " <> ppr nm + name nm = braces $ text "Name:" <+> ppr nm occName n = braces $ - text "OccName: " - <> text (occNameString n) + text "OccName:" + <+> text (occNameString n) moduleName :: ModuleName -> SDoc - moduleName m = braces $ text "ModuleName: " <> ppr m + moduleName m = braces $ text "ModuleName:" <+> ppr m srcSpan :: SrcSpan -> SDoc - srcSpan ss = case b of + srcSpan ss = case bs of BlankSrcSpan -> text "{ ss }" NoBlankSrcSpan -> braces $ char ' ' <> (hang (ppr ss) 1 -- TODO: show annotations here (text "")) + BlankSrcSpanFile -> braces $ char ' ' <> + (hang (pprUserSpan False ss) 1 + -- TODO: show annotations here + (text "")) + + realSrcSpan :: RealSrcSpan -> SDoc + realSrcSpan ss = case bs of + BlankSrcSpan -> text "{ ss }" + NoBlankSrcSpan -> braces $ char ' ' <> + (hang (ppr ss) 1 + -- TODO: show annotations here + (text "")) + BlankSrcSpanFile -> braces $ char ' ' <> + (hang (pprUserRealSpan False ss) 1 + -- TODO: show annotations here + (text "")) + + + addApiAnn :: AddApiAnn -> SDoc + addApiAnn (AddApiAnn a s) = case ba of + BlankApiAnnotations -> parens + $ text "blanked:" <+> text "AddApiAnn" + NoBlankApiAnnotations -> + parens $ text "AddApiAnn" <+> ppr a <+> annAnchor s var :: Var -> SDoc - var v = braces $ text "Var: " <> ppr v + var v = braces $ text "Var:" <+> ppr v dataCon :: DataCon -> SDoc - dataCon c = braces $ text "DataCon: " <> ppr c + dataCon c = braces $ text "DataCon:" <+> ppr c - bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc + bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc bagRdrName bg = braces $ - text "Bag(Located (HsBind GhcPs)):" + text "Bag(LocatedA (HsBind GhcPs)):" $$ (list . bagToList $ bg) - bagName :: Bag (Located (HsBind GhcRn)) -> SDoc + bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc bagName bg = braces $ - text "Bag(Located (HsBind Name)):" + text "Bag(LocatedA (HsBind Name)):" $$ (list . bagToList $ bg) - bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc + bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc bagVar bg = braces $ - text "Bag(Located (HsBind Var)):" + text "Bag(LocatedA (HsBind Var)):" $$ (list . bagToList $ bg) nameSet ns = braces $ @@ -151,16 +211,82 @@ showAstData b a0 = blankLine $$ showAstData' a0 fixity :: Fixity -> SDoc fixity fx = braces $ - text "Fixity: " - <> ppr fx - - located :: (Data b,Data loc) => GenLocated loc b -> SDoc - located (L ss a) = parens $ - case cast ss of - Just (s :: SrcSpan) -> - srcSpan s - Nothing -> text "nnnnnnnn" - $$ showAstData' a + text "Fixity:" + <+> ppr fx + + located :: (Data a, Data b) => GenLocated a b -> SDoc + located (L ss a) + = parens (text "L" + $$ vcat [showAstData' ss, showAstData' a]) + + + -- ------------------------- + + annotation :: ApiAnn -> SDoc + annotation = annotation' (text "ApiAnn") + + annotationModule :: ApiAnn' AnnsModule -> SDoc + annotationModule = annotation' (text "ApiAnn' AnnsModule") + + annotationAddApiAnn :: ApiAnn' AddApiAnn -> SDoc + annotationAddApiAnn = annotation' (text "ApiAnn' AddApiAnn") + + annotationGrhsAnn :: ApiAnn' GrhsAnn -> SDoc + annotationGrhsAnn = annotation' (text "ApiAnn' GrhsAnn") + + annotationApiAnnHsCase :: ApiAnn' ApiAnnHsCase -> SDoc + annotationApiAnnHsCase = annotation' (text "ApiAnn' ApiAnnHsCase") + + annotationAnnList :: ApiAnn' AnnList -> SDoc + annotationAnnList = annotation' (text "ApiAnn' AnnList") + + annotationApiAnnImportDecl :: ApiAnn' ApiAnnImportDecl -> SDoc + annotationApiAnnImportDecl = annotation' (text "ApiAnn' ApiAnnImportDecl") + + annotationAnnParen :: ApiAnn' AnnParen -> SDoc + annotationAnnParen = annotation' (text "ApiAnn' AnnParen") + + annotationTrailingAnn :: ApiAnn' TrailingAnn -> SDoc + annotationTrailingAnn = annotation' (text "ApiAnn' TrailingAnn") + + annotation' :: forall a .(Data a, Typeable a) + => SDoc -> ApiAnn' a -> SDoc + annotation' tag anns = case ba of + BlankApiAnnotations -> parens (text "blanked:" <+> tag) + NoBlankApiAnnotations -> parens $ text (showConstr (toConstr anns)) + $$ vcat (gmapQ showAstData' anns) + + -- ------------------------- + + srcSpanAnnA :: SrcSpanAnn' (ApiAnn' AnnListItem) -> SDoc + srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") + + srcSpanAnnL :: SrcSpanAnn' (ApiAnn' AnnList) -> SDoc + srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") + + srcSpanAnnP :: SrcSpanAnn' (ApiAnn' AnnPragma) -> SDoc + srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") + + srcSpanAnnC :: SrcSpanAnn' (ApiAnn' AnnContext) -> SDoc + srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") + + srcSpanAnnN :: SrcSpanAnn' (ApiAnn' NameAnn) -> SDoc + srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") + + locatedAnn'' :: forall a. (Typeable a, Data a) + => SDoc -> SrcSpanAnn' a -> SDoc + locatedAnn'' tag ss = parens $ + case cast ss of + Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) -> + case ba of + BlankApiAnnotations + -> parens (text "blanked:" <+> tag) + NoBlankApiAnnotations + -> text "SrcSpanAnn" <+> showAstData' ann + <+> srcSpan s + Nothing -> text "locatedAnn:unmatched" <+> tag + <+> (parens $ text (showConstr (toConstr ss))) + normalize_newlines :: String -> String normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index e1f6e3fd3b..9d3e3dcf39 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -41,6 +42,7 @@ import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Hs.Type import GHC.Hs.Binds +import GHC.Parser.Annotation -- others: import GHC.Tc.Types.Evidence @@ -120,7 +122,7 @@ data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr (GhcPass p) -noExpr = HsLit noExtField (HsString (SourceText "noExpr") (fsLit "noExpr")) +noExpr = HsLit noComments (HsString (SourceText "noExpr") (fsLit "noExpr")) noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) -- Before renaming, and sometimes after @@ -139,7 +141,7 @@ mkSyntaxExpr = SyntaxExprRn -- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the -- renamer). mkRnSyntaxExpr :: Name -> SyntaxExprRn -mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLoc name +mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name instance Outputable SyntaxExprRn where ppr (SyntaxExprRn expr) = ppr expr @@ -202,23 +204,35 @@ It would be better to omit the pattern match altogether, but we could only do that if the extension field was strict (#18764) -} +-- API Annotations types + +data ApiAnnHsCase = ApiAnnHsCase + { hsCaseAnnCase :: AnnAnchor + , hsCaseAnnOf :: AnnAnchor + , hsCaseAnnsRest :: [AddApiAnn] + } deriving Data + +data ApiAnnUnboundVar = ApiAnnUnboundVar + { hsUnboundBackquotes :: (AnnAnchor, AnnAnchor) + , hsUnboundHole :: AnnAnchor + } deriving Data + type instance XVar (GhcPass _) = NoExtField type instance XConLikeOut (GhcPass _) = NoExtField type instance XRecFld (GhcPass _) = NoExtField -type instance XIPVar (GhcPass _) = NoExtField -type instance XOverLitE (GhcPass _) = NoExtField -type instance XLitE (GhcPass _) = NoExtField type instance XLam (GhcPass _) = NoExtField -type instance XLamCase (GhcPass _) = NoExtField -type instance XApp (GhcPass _) = NoExtField -- OverLabel not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] -type instance XOverLabel GhcPs = NoExtField -type instance XOverLabel GhcRn = NoExtField +type instance XOverLabel GhcPs = ApiAnnCO +type instance XOverLabel GhcRn = ApiAnnCO type instance XOverLabel GhcTc = Void -- See Note [Constructor cannot occur] -type instance XUnboundVar GhcPs = NoExtField +-- --------------------------------------------------------------------- + +type instance XVar (GhcPass _) = NoExtField + +type instance XUnboundVar GhcPs = ApiAnn' ApiAnnUnboundVar type instance XUnboundVar GhcRn = NoExtField type instance XUnboundVar GhcTc = HoleExprRef -- We really don't need the whole HoleExprRef; just the IORef EvTerm @@ -226,49 +240,72 @@ type instance XUnboundVar GhcTc = HoleExprRef -- Much, much easier just to define HoleExprRef with a Data instance and -- store the whole structure. -type instance XAppTypeE GhcPs = NoExtField +type instance XConLikeOut (GhcPass _) = NoExtField +type instance XRecFld (GhcPass _) = NoExtField +type instance XIPVar (GhcPass _) = ApiAnnCO +type instance XOverLitE (GhcPass _) = ApiAnnCO +type instance XLitE (GhcPass _) = ApiAnnCO + +type instance XLam (GhcPass _) = NoExtField + +type instance XLamCase (GhcPass _) = ApiAnn +type instance XApp (GhcPass _) = ApiAnnCO + +type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives type instance XAppTypeE GhcRn = NoExtField type instance XAppTypeE GhcTc = Type -- OpApp not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] -type instance XOpApp GhcPs = NoExtField +type instance XOpApp GhcPs = ApiAnn type instance XOpApp GhcRn = Fixity type instance XOpApp GhcTc = Void -- See Note [Constructor cannot occur] -- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] -type instance XSectionL GhcPs = NoExtField -type instance XSectionR GhcPs = NoExtField -type instance XSectionL GhcRn = NoExtField -type instance XSectionR GhcRn = NoExtField +type instance XSectionL GhcPs = ApiAnnCO +type instance XSectionR GhcPs = ApiAnnCO +type instance XSectionL GhcRn = ApiAnnCO +type instance XSectionR GhcRn = ApiAnnCO type instance XSectionL GhcTc = Void -- See Note [Constructor cannot occur] type instance XSectionR GhcTc = Void -- See Note [Constructor cannot occur] -type instance XNegApp (GhcPass _) = NoExtField -type instance XPar (GhcPass _) = NoExtField -type instance XExplicitTuple (GhcPass _) = NoExtField +type instance XNegApp GhcPs = ApiAnn +type instance XNegApp GhcRn = NoExtField +type instance XNegApp GhcTc = NoExtField + +type instance XPar (GhcPass _) = ApiAnn' AnnParen + +type instance XExplicitTuple GhcPs = ApiAnn +type instance XExplicitTuple GhcRn = NoExtField +type instance XExplicitTuple GhcTc = NoExtField -type instance XExplicitSum GhcPs = NoExtField +type instance XExplicitSum GhcPs = ApiAnn' AnnExplicitSum type instance XExplicitSum GhcRn = NoExtField type instance XExplicitSum GhcTc = [Type] -type instance XCase (GhcPass _) = NoExtField +type instance XCase GhcPs = ApiAnn' ApiAnnHsCase +type instance XCase GhcRn = NoExtField +type instance XCase GhcTc = NoExtField -type instance XIf (GhcPass _) = NoExtField +type instance XIf GhcPs = ApiAnn +type instance XIf GhcRn = NoExtField +type instance XIf GhcTc = NoExtField -type instance XMultiIf GhcPs = NoExtField +type instance XMultiIf GhcPs = ApiAnn type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type -type instance XLet (GhcPass _) = NoExtField +type instance XLet GhcPs = ApiAnn' AnnsLet +type instance XLet GhcRn = NoExtField +type instance XLet GhcTc = NoExtField -type instance XDo GhcPs = NoExtField +type instance XDo GhcPs = ApiAnn' AnnList type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = NoExtField +type instance XExplicitList GhcPs = ApiAnn' AnnList type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level @@ -279,41 +316,43 @@ type instance XExplicitList GhcTc = Type -- See Note [Handling overloaded and rebindable constructs] -- in GHC.Rename.Expr -type instance XRecordCon GhcPs = NoExtField +type instance XRecordCon GhcPs = ApiAnn type instance XRecordCon GhcRn = NoExtField type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function -type instance XRecordUpd GhcPs = NoExtField +type instance XRecordUpd GhcPs = ApiAnn type instance XRecordUpd GhcRn = NoExtField type instance XRecordUpd GhcTc = RecordUpdTc -type instance XGetField GhcPs = NoExtField +type instance XGetField GhcPs = ApiAnnCO type instance XGetField GhcRn = NoExtField type instance XGetField GhcTc = Void -- HsGetField is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XProjection GhcPs = NoExtField +type instance XProjection GhcPs = ApiAnn' AnnProjection type instance XProjection GhcRn = NoExtField type instance XProjection GhcTc = Void -- HsProjection is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XExprWithTySig (GhcPass _) = NoExtField +type instance XExprWithTySig GhcPs = ApiAnn +type instance XExprWithTySig GhcRn = NoExtField +type instance XExprWithTySig GhcTc = NoExtField -type instance XArithSeq GhcPs = NoExtField +type instance XArithSeq GhcPs = ApiAnn type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr -type instance XBracket (GhcPass _) = NoExtField +type instance XBracket (GhcPass _) = ApiAnn type instance XRnBracketOut (GhcPass _) = NoExtField type instance XTcBracketOut (GhcPass _) = NoExtField -type instance XSpliceE (GhcPass _) = NoExtField -type instance XProc (GhcPass _) = NoExtField +type instance XSpliceE (GhcPass _) = ApiAnnCO +type instance XProc (GhcPass _) = ApiAnn -type instance XStatic GhcPs = NoExtField +type instance XStatic GhcPs = ApiAnn type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = NameSet @@ -329,26 +368,58 @@ type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) type instance XXExpr GhcTc = XXExprGhcTc + +type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL +type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA + data XXExprGhcTc = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr) | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)) +data AnnExplicitSum + = AnnExplicitSum { + aesOpen :: AnnAnchor, + aesBarsBefore :: [AnnAnchor], + aesBarsAfter :: [AnnAnchor], + aesClose :: AnnAnchor + } deriving Data + +data AnnsLet + = AnnsLet { + alLet :: AnnAnchor, + alIn :: AnnAnchor + } deriving Data + +data AnnFieldLabel + = AnnFieldLabel { + afDot :: Maybe AnnAnchor + } deriving Data + +data AnnProjection + = AnnProjection { + apOpen :: AnnAnchor, -- ^ '(' + apClose :: AnnAnchor -- ^ ')' + } deriving Data + -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = NoExtField +type instance XSCC (GhcPass _) = ApiAnn' AnnPragma type instance XXPragE (GhcPass _) = NoExtCon -type instance XPresent (GhcPass _) = NoExtField +type instance XCHsFieldLabel (GhcPass _) = ApiAnn' AnnFieldLabel +type instance XXHsFieldLabel (GhcPass _) = NoExtCon -type instance XMissing GhcPs = NoExtField +type instance XPresent (GhcPass _) = ApiAnn + +type instance XMissing GhcPs = ApiAnn' AnnAnchor type instance XMissing GhcRn = NoExtField type instance XMissing GhcTc = Scaled Type type instance XXTupArg (GhcPass _) = NoExtCon -tupArgPresent :: LHsTupArg (GhcPass p) -> Bool -tupArgPresent (L _ (Present {})) = True -tupArgPresent (L _ (Missing {})) = False +tupArgPresent :: HsTupArg (GhcPass p) -> Bool +tupArgPresent (Present {}) = True +tupArgPresent (Missing {}) = False instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where ppr expr = pprExpr expr @@ -446,11 +517,11 @@ ppr_expr (SectionR _ op expr) ppr_expr (ExplicitTuple _ exprs boxity) -- Special-case unary boxed tuples so that they are pretty-printed as -- `Solo x`, not `(x)` - | [L _ (Present _ expr)] <- exprs + | [Present _ expr] <- exprs , Boxed <- boxity = hsep [text (mkTupleStr Boxed 1), ppr expr] | otherwise - = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) + = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs)) where ppr_tup_args [] = [] ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es @@ -473,12 +544,12 @@ ppr_expr (HsLamCase _ matches) = sep [ sep [text "\\case"], nest 2 (pprMatches matches) ] -ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches matches) <+> char '}'] -ppr_expr (HsCase _ expr matches) +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts })) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], - nest 2 (pprMatches matches) ] + pp_alts ] + where + pp_alts | null alts = text "{}" + | otherwise = nest 2 (pprMatches matches) ppr_expr (HsIf _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], @@ -498,11 +569,11 @@ ppr_expr (HsMultiIf _ alts) ppr_alt (L _ (XGRHS x)) = ppr x -- special case: let ... in let ... -ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) +ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lexpr expr] -ppr_expr (HsLet _ (L _ binds) expr) +ppr_expr (HsLet _ binds expr) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr expr)] @@ -529,7 +600,7 @@ ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds }) ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field }) = ppr fexp <> dot <> ppr field -ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (punctuate dot (map ppr flds))) +ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr flds)))) ppr_expr (ExprWithTySig _ expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) @@ -646,7 +717,7 @@ hsExprNeedsParens p = go -- Special-case unary boxed tuple applications so that they are -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) -- See Note [One-tuples] in GHC.Builtin.Types - go (ExplicitTuple _ [L _ Present{}] Boxed) + go (ExplicitTuple _ [Present{}] Boxed) = p >= appPrec go (ExplicitTuple{}) = False go (ExplicitSum{}) = False @@ -693,7 +764,7 @@ hsExprNeedsParens p = go -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) parenthesizeHsExpr p le@(L loc e) - | hsExprNeedsParens p e = L loc (HsPar noExtField le) + | hsExprNeedsParens p e = L loc (HsPar noAnn le) | otherwise = le stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) @@ -723,7 +794,7 @@ isAtomicHsExpr (XExpr x) isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where - ppr (HsPragSCC _ st (StringLiteral stl lbl)) = + ppr (HsPragSCC _ st (StringLiteral stl lbl _)) = pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes. @@ -910,20 +981,33 @@ instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ************************************************************************ -} -type instance XCmdArrApp GhcPs = NoExtField +type instance XCmdArrApp GhcPs = ApiAnn' AddApiAnn type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm (GhcPass _) = NoExtField -type instance XCmdApp (GhcPass _) = NoExtField +type instance XCmdArrForm GhcPs = ApiAnn' AnnList +type instance XCmdArrForm GhcRn = NoExtField +type instance XCmdArrForm GhcTc = NoExtField + +type instance XCmdApp (GhcPass _) = ApiAnnCO type instance XCmdLam (GhcPass _) = NoExtField -type instance XCmdPar (GhcPass _) = NoExtField -type instance XCmdCase (GhcPass _) = NoExtField -type instance XCmdLamCase (GhcPass _) = NoExtField -type instance XCmdIf (GhcPass _) = NoExtField -type instance XCmdLet (GhcPass _) = NoExtField +type instance XCmdPar (GhcPass _) = ApiAnn' AnnParen + +type instance XCmdCase GhcPs = ApiAnn' ApiAnnHsCase +type instance XCmdCase GhcRn = NoExtField +type instance XCmdCase GhcTc = NoExtField -type instance XCmdDo GhcPs = NoExtField +type instance XCmdLamCase (GhcPass _) = ApiAnn + +type instance XCmdIf GhcPs = ApiAnn +type instance XCmdIf GhcRn = NoExtField +type instance XCmdIf GhcTc = NoExtField + +type instance XCmdLet GhcPs = ApiAnn' AnnsLet +type instance XCmdLet GhcRn = NoExtField +type instance XCmdLet GhcTc = NoExtField + +type instance XCmdDo GhcPs = ApiAnn' AnnList type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type @@ -932,6 +1016,10 @@ type instance XCmdWrap (GhcPass _) = NoExtField type instance XXCmd GhcPs = NoExtCon type instance XXCmd GhcRn = NoExtCon type instance XXCmd GhcTc = HsWrap HsCmd + +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] + = SrcSpanAnnL + -- If cmd :: arg1 --> res -- wrap :: arg1 "->" arg2 -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res @@ -973,7 +1061,8 @@ isQuietHsCmd _ = False ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc +ppr_cmd :: forall p. (OutputableBndrId p + ) => HsCmd (GhcPass p) -> SDoc ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp _ c e) @@ -1000,11 +1089,11 @@ ppr_cmd (HsCmdIf _ _ e ct ce) nest 4 (ppr ce)] -- special case: let ... in let ... -ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) +ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {}))) = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), ppr_lcmd cmd] -ppr_cmd (HsCmdLet _ (L _ binds) cmd) +ppr_cmd (HsCmdLet _ binds cmd) = sep [hang (text "let") 2 (pprBinds binds), hang (text "in") 2 (ppr cmd)] @@ -1063,7 +1152,7 @@ type instance XMG GhcTc b = MatchGroupTc type instance XXMatchGroup (GhcPass _) b = NoExtCon -type instance XCMatch (GhcPass _) b = NoExtField +type instance XCMatch (GhcPass _) b = ApiAnn type instance XXMatch (GhcPass _) b = NoExtCon instance (OutputableBndrId pr, Outputable body) @@ -1092,10 +1181,19 @@ matchGroupArity (MG { mg_alts = alts }) hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = pats })) = pats -type instance XCGRHSs (GhcPass _) b = NoExtField -type instance XXGRHSs (GhcPass _) b = NoExtCon +type instance XCGRHSs (GhcPass _) _ = NoExtField +type instance XXGRHSs (GhcPass _) _ = NoExtCon + +data GrhsAnn + = GrhsAnn { + ga_vbar :: Maybe AnnAnchor, -- TODO:AZ do we need this? + ga_sep :: AddApiAnn -- ^ Match separator location + } deriving (Data) + +type instance XCGRHS (GhcPass _) _ = ApiAnn' GrhsAnn + -- Location of matchSeparator + -- TODO:AZ does this belong on the GRHS, or GRHSs? -type instance XCGRHS (GhcPass _) b = NoExtField type instance XXGRHS (GhcPass _) b = NoExtCon pprMatches :: (OutputableBndrId idR, Outputable body) @@ -1105,16 +1203,15 @@ pprMatches MG { mg_alts = matches } -- Don't print the type; it's only a place-holder before typechecking -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId idR, Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind :: (OutputableBndrId idR) + => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc pprFunBind matches = pprMatches matches -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p body. (OutputableBndrId bndr, - OutputableBndrId p, - Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc -pprPatBind pat (grhss) +pprPatBind :: forall bndr p . (OutputableBndrId bndr, + OutputableBndrId p) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc +pprPatBind pat grhss = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)] @@ -1155,7 +1252,7 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss }) pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc -pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) +pprGRHSs ctxt (GRHSs _ grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) -- Print the "where" even if the contents of the binds is empty. Only -- EmptyLocalBinds means no "where" keyword @@ -1173,6 +1270,9 @@ pprGRHS ctxt (GRHS _ guards body) pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) +instance Outputable GrhsAnn where + ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s + {- ************************************************************************ * * @@ -1204,7 +1304,7 @@ data RecStmtTc = type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField -type instance XBindStmt (GhcPass _) GhcPs b = NoExtField +type instance XBindStmt (GhcPass _) GhcPs b = ApiAnn type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc @@ -1228,17 +1328,17 @@ type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField type instance XBodyStmt (GhcPass _) GhcTc b = Type -type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExtField +type instance XLetStmt (GhcPass _) (GhcPass _) b = ApiAnn type instance XParStmt (GhcPass _) GhcPs b = NoExtField type instance XParStmt (GhcPass _) GhcRn b = NoExtField type instance XParStmt (GhcPass _) GhcTc b = Type -type instance XTransStmt (GhcPass _) GhcPs b = NoExtField +type instance XTransStmt (GhcPass _) GhcPs b = ApiAnn type instance XTransStmt (GhcPass _) GhcRn b = NoExtField type instance XTransStmt (GhcPass _) GhcTc b = Type -type instance XRecStmt (GhcPass _) GhcPs b = NoExtField +type instance XRecStmt (GhcPass _) GhcPs b = ApiAnn' AnnList type instance XRecStmt (GhcPass _) GhcRn b = NoExtField type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc @@ -1262,12 +1362,14 @@ instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL)) ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts instance (OutputableBndrId pl, OutputableBndrId pr, + Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA, Outputable body) => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where ppr stmt = pprStmt stmt pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, Outputable body) => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc pprStmt (LastStmt _ expr m_dollar_stripped _) @@ -1277,10 +1379,10 @@ pprStmt (LastStmt _ expr m_dollar_stripped _) Just False -> text "return" Nothing -> empty) <+> ppr expr -pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr -pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] -pprStmt (BodyStmt _ expr _ _) = ppr expr -pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) +pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr +pprStmt (LetStmt _ binds) = hsep [text "let", pprBinds binds] +pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) pprStmt (TransStmt { trS_stmts = stmts, trS_by = by , trS_using = using, trS_form = form }) @@ -1289,7 +1391,7 @@ pprStmt (TransStmt { trS_stmts = stmts, trS_by = by pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) = text "rec" <+> - vcat [ ppr_do_stmts segment + vcat [ ppr_do_stmts (unLoc segment) , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids , text "later_ids=" <> ppr later_ids])] @@ -1343,7 +1445,7 @@ pprArg (ApplicativeArgMany _ stmts return pat ctxt) = ppr pat <+> text "<-" <+> pprDo ctxt (stmts ++ - [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]) + [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)]) pprTransformStmt :: (OutputableBndrId p) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) @@ -1363,7 +1465,9 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (OutputableBndrId p, Outputable body) +pprDo :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA + ) => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc pprDo (DoExpr m) stmts = ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts @@ -1381,12 +1485,14 @@ ppr_module_name_prefix = \case Just module_name -> ppr module_name <> char '.' ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, Outputable body) => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc -- Print a bunch of do stmts ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) -pprComp :: (OutputableBndrId p, Outputable body) +pprComp :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) => [LStmt (GhcPass p) body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals @@ -1401,7 +1507,8 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (OutputableBndrId p, Outputable body) +pprQuals :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) => [LStmt (GhcPass p) body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -1416,8 +1523,8 @@ pprQuals quals = interpp'SP quals newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data) -type instance XTypedSplice (GhcPass _) = NoExtField -type instance XUntypedSplice (GhcPass _) = NoExtField +type instance XTypedSplice (GhcPass _) = ApiAnn +type instance XUntypedSplice (GhcPass _) = ApiAnn type instance XQuasiQuote (GhcPass _) = NoExtField type instance XSpliced (GhcPass _) = NoExtField type instance XXSplice GhcPs = NoExtCon @@ -1585,9 +1692,9 @@ pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) pprHsBracket (VarBr _ True n) - = char '\'' <> pprPrefixOcc n + = char '\'' <> pprPrefixOcc (unLoc n) pprHsBracket (VarBr _ False n) - = text "''" <> pprPrefixOcc n + = text "''" <> pprPrefixOcc (unLoc n) pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) thBrackets :: SDoc -> SDoc -> SDoc @@ -1682,7 +1789,8 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, - Outputable body) + Outputable body, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) => HsStmtContext (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc @@ -1698,3 +1806,38 @@ pprStmtInCtxt ctxt stmt ppr_stmt (TransStmt { trS_by = by, trS_using = using , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA +type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL +type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL + +type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA + +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] + = SrcSpanAnnL +type instance Anno (HsCmdTop (GhcPass p)) = SrcSpan +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnL +type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA +type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA +type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpan +type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpan +type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA +type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))) = SrcSpanAnnA + +type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA + +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL + +instance (Anno a ~ SrcSpanAnn' (ApiAnn' an)) + => WrapXRec (GhcPass p) a where + wrapXRec = noLocA diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot index 0f115387f6..204af54681 100644 --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -20,8 +20,8 @@ import Language.Haskell.Syntax.Expr ) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) -instance OutputableBndrId p => Outputable (HsExpr (GhcPass p)) -instance OutputableBndrId p => Outputable (HsCmd (GhcPass p)) +instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) +instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc @@ -32,10 +32,9 @@ pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc pprSpliceDecl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprPatBind :: forall bndr p body. (OutputableBndrId bndr, - OutputableBndrId p, - Outputable body) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc +pprPatBind :: forall bndr p . (OutputableBndrId bndr, + OutputableBndrId p) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc -pprFunBind :: (OutputableBndrId idR, Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind :: (OutputableBndrId idR) + => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index ac79d83d0b..3b317f569f 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -28,9 +27,10 @@ import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.Var -import GHC.Utils.Outputable -import GHC.Types.SrcLoc (Located, unLoc, noLoc) +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Types.SrcLoc (GenLocated(..), unLoc) import GHC.Utils.Panic +import GHC.Parser.Annotation {- Note [IsPass] @@ -67,7 +67,7 @@ Type. We never build an HsType GhcTc. Why do this? Because we need to be able to compare type-checked types for equality, and we don't want to do this with HsType. -This causes wrinkles within the AST, where we normally thing that the whole +This causes wrinkles within the AST, where we normally think that the whole AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc. @@ -94,14 +94,23 @@ saying that NoGhcTcPass is idempotent. -} -type instance XRec (GhcPass p) a = Located a +-- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation +type instance XRec (GhcPass p) a = GenLocated (Anno a) a + +type instance Anno RdrName = SrcSpanAnnN +type instance Anno Name = SrcSpanAnnN +type instance Anno Id = SrcSpanAnnN + +type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (ApiAnn' a), + IsPass p) instance UnXRec (GhcPass p) where unXRec = unLoc instance MapXRec (GhcPass p) where mapXRec = fmap -instance WrapXRec (GhcPass p) where - wrapXRec = noLoc + +-- instance WrapXRec (GhcPass p) a where +-- wrapXRec = noLocA {- Note [NoExtCon and strict fields] @@ -203,6 +212,8 @@ type family NoGhcTcPass (p :: Pass) :: Pass where type OutputableBndrId pass = ( OutputableBndr (IdGhcP pass) , OutputableBndr (IdGhcP (NoGhcTcPass pass)) + , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass)) + , Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass))) , IsPass pass ) diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index f290c458b2..f4c40bd185 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -20,7 +20,6 @@ import GHC.Prelude import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) import GHC.Hs.Doc ( HsDocString ) -import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc ) import GHC.Types.SourceText ( SourceText(..), StringLiteral(..), pprWithSourceText ) import GHC.Types.FieldLabel ( FieldLabel ) @@ -30,6 +29,8 @@ import GHC.Data.FastString import GHC.Types.SrcLoc import Language.Haskell.Syntax.Extension import GHC.Hs.Extension +import GHC.Parser.Annotation +import GHC.Types.Name import Data.Data import Data.Maybe @@ -51,6 +52,7 @@ type LImportDecl pass = XRec pass (ImportDecl pass) -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' -- For details on above see note [Api annotations] in GHC.Parser.Annotation +type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA -- | If/how an import is 'qualified'. data ImportDeclQualifiedStyle @@ -62,12 +64,12 @@ data ImportDeclQualifiedStyle -- | Given two possible located 'qualified' tokens, compute a style -- (in a conforming Haskell program only one of the two can be not -- 'Nothing'). This is called from "GHC.Parser". -importDeclQualifiedStyle :: Maybe (Located a) - -> Maybe (Located a) - -> ImportDeclQualifiedStyle +importDeclQualifiedStyle :: Maybe AnnAnchor + -> Maybe AnnAnchor + -> (Maybe AnnAnchor, ImportDeclQualifiedStyle) importDeclQualifiedStyle mPre mPost = - if isJust mPre then QualifiedPre - else if isJust mPost then QualifiedPost else NotQualified + if isJust mPre then (mPre, QualifiedPre) + else if isJust mPost then (mPost,QualifiedPost) else (Nothing, NotQualified) -- | Convenience function to answer the question if an import decl. is -- qualified. @@ -111,12 +113,33 @@ data ImportDecl pass -- For details on above see note [Api annotations] in GHC.Parser.Annotation -type instance XCImportDecl (GhcPass _) = NoExtField +type instance XCImportDecl GhcPs = ApiAnn' ApiAnnImportDecl +type instance XCImportDecl GhcRn = NoExtField +type instance XCImportDecl GhcTc = NoExtField + type instance XXImportDecl (GhcPass _) = NoExtCon -simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) +type instance Anno ModuleName = SrcSpan +type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL + +-- --------------------------------------------------------------------- + +-- API Annotations types + +data ApiAnnImportDecl = ApiAnnImportDecl + { importDeclAnnImport :: AnnAnchor + , importDeclAnnPragma :: Maybe (AnnAnchor, AnnAnchor) + , importDeclAnnSafe :: Maybe AnnAnchor + , importDeclAnnQualified :: Maybe AnnAnchor + , importDeclAnnPackage :: Maybe AnnAnchor + , importDeclAnnAs :: Maybe AnnAnchor + } deriving (Data) + +-- --------------------------------------------------------------------- + +simpleImportDecl :: ModuleName -> ImportDecl GhcPs simpleImportDecl mn = ImportDecl { - ideclExt = noExtField, + ideclExt = noAnn, ideclSourceSrc = NoSourceText, ideclName = noLoc mn, ideclPkgQual = Nothing, @@ -128,7 +151,8 @@ simpleImportDecl mn = ImportDecl { ideclHiding = Nothing } -instance OutputableBndrId p +instance (OutputableBndrId p + , Outputable (Anno (IE (GhcPass p)))) => Outputable (ImportDecl (GhcPass p)) where ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' , ideclPkgQual = pkg @@ -143,7 +167,7 @@ instance OutputableBndrId p pp_implicit True = ptext (sLit ("(implicit)")) pp_pkg Nothing = empty - pp_pkg (Just (StringLiteral st p)) + pp_pkg (Just (StringLiteral st p _)) = pprWithSourceText st (doubleQuotes (ftext p)) pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. @@ -178,19 +202,21 @@ instance OutputableBndrId p ************************************************************************ -} --- | A name in an import or export specification which may have adornments. Used --- primarily for accurate pretty printing of ParsedSource, and API Annotation --- placement. +-- | A name in an import or export specification which may have +-- adornments. Used primarily for accurate pretty printing of +-- ParsedSource, and API Annotation placement. The +-- 'GHC.Parser.Annotation' is the location of the adornment in +-- the original source. data IEWrappedName name - = IEName (Located name) -- ^ no extra - | IEPattern (Located name) -- ^ pattern X - | IEType (Located name) -- ^ type (:+:) + = IEName (LocatedN name) -- ^ no extra + | IEPattern AnnAnchor (LocatedN name) -- ^ pattern X + | IEType AnnAnchor (LocatedN name) -- ^ type (:+:) deriving (Eq,Data) -- | Located name with possible adornment -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', -- 'GHC.Parser.Annotation.AnnPattern' -type LIEWrappedName name = Located (IEWrappedName name) +type LIEWrappedName name = LocatedA (IEWrappedName name) -- For details on above see note [Api annotations] in GHC.Parser.Annotation @@ -201,6 +227,7 @@ type LIE pass = XRec pass (IE pass) -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' -- For details on above see note [Api annotations] in GHC.Parser.Annotation +type instance Anno (IE (GhcPass p)) = SrcSpanAnnA -- | Imported or exported entity. data IE pass @@ -255,20 +282,28 @@ data IE pass | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc | XIE !(XXIE pass) -type instance XIEVar (GhcPass _) = NoExtField -type instance XIEThingAbs (GhcPass _) = NoExtField -type instance XIEThingAll (GhcPass _) = NoExtField -type instance XIEModuleContents (GhcPass _) = NoExtField -type instance XIEGroup (GhcPass _) = NoExtField -type instance XIEDoc (GhcPass _) = NoExtField -type instance XIEDocNamed (GhcPass _) = NoExtField -type instance XXIE (GhcPass _) = NoExtCon +type instance XIEVar GhcPs = NoExtField +type instance XIEVar GhcRn = NoExtField +type instance XIEVar GhcTc = NoExtField + +type instance XIEThingAbs (GhcPass _) = ApiAnn +type instance XIEThingAll (GhcPass _) = ApiAnn -- See Note [IEThingWith] +type instance XIEThingWith (GhcPass 'Parsed) = ApiAnn type instance XIEThingWith (GhcPass 'Renamed) = [Located FieldLabel] -type instance XIEThingWith (GhcPass 'Parsed) = NoExtField type instance XIEThingWith (GhcPass 'Typechecked) = NoExtField +type instance XIEModuleContents GhcPs = ApiAnn +type instance XIEModuleContents GhcRn = NoExtField +type instance XIEModuleContents GhcTc = NoExtField + +type instance XIEGroup (GhcPass _) = NoExtField +type instance XIEDoc (GhcPass _) = NoExtField +type instance XIEDocNamed (GhcPass _) = NoExtField +type instance XXIE (GhcPass _) = NoExtCon + +type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) @@ -318,18 +353,25 @@ ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] +ieWrappedLName :: IEWrappedName name -> LocatedN name +ieWrappedLName (IEName ln) = ln +ieWrappedLName (IEPattern _ ln) = ln +ieWrappedLName (IEType _ ln) = ln + ieWrappedName :: IEWrappedName name -> name -ieWrappedName (IEName (L _ n)) = n -ieWrappedName (IEPattern (L _ n)) = n -ieWrappedName (IEType (L _ n)) = n +ieWrappedName = unLoc . ieWrappedLName + lieWrappedName :: LIEWrappedName name -> name lieWrappedName (L _ n) = ieWrappedName n +ieLWrappedName :: LIEWrappedName name -> LocatedN name +ieLWrappedName (L _ n) = ieWrappedLName n + replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 -replaceWrappedName (IEName (L l _)) n = IEName (L l n) -replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n) -replaceWrappedName (IEType (L l _)) n = IEType (L l n) +replaceWrappedName (IEName (L l _)) n = IEName (L l n) +replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n) +replaceWrappedName (IEType r (L l _)) n = IEType r (L l n) replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') @@ -368,9 +410,9 @@ instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where pprInfixOcc w = pprInfixOcc (ieWrappedName w) instance (OutputableBndr name) => Outputable (IEWrappedName name) where - ppr (IEName n) = pprPrefixOcc (unLoc n) - ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) - ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) + ppr (IEName n) = pprPrefixOcc (unLoc n) + ppr (IEPattern _ n) = text "pattern" <+> pprPrefixOcc (unLoc n) + ppr (IEType _ n) = text "type" <+> pprPrefixOcc (unLoc n) pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 7fa71a90e1..68b55196ca 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -32,8 +32,7 @@ import GHC.Hs.Lit import GHC.Hs.Type import GHC.Hs.Pat import GHC.Hs.ImpExp - -import GHC.Types.SrcLoc ( Located ) +import GHC.Parser.Annotation -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs----------------------------------------- @@ -133,6 +132,11 @@ deriving instance Data (TyClDecl GhcPs) deriving instance Data (TyClDecl GhcRn) deriving instance Data (TyClDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (FunDep p) +deriving instance Data (FunDep GhcPs) +deriving instance Data (FunDep GhcRn) +deriving instance Data (FunDep GhcTc) + -- deriving instance (DataIdLR p p) => Data (TyClGroup p) deriving instance Data (TyClGroup GhcPs) deriving instance Data (TyClGroup GhcRn) @@ -254,6 +258,10 @@ deriving instance Data (WarnDecl GhcRn) deriving instance Data (WarnDecl GhcTc) -- deriving instance (DataIdLR p p) => Data (AnnDecl p) +deriving instance Data (AnnProvenance GhcPs) +deriving instance Data (AnnProvenance GhcRn) +deriving instance Data (AnnProvenance GhcTc) + deriving instance Data (AnnDecl GhcPs) deriving instance Data (AnnDecl GhcRn) deriving instance Data (AnnDecl GhcTc) @@ -266,6 +274,14 @@ deriving instance Data (RoleAnnotDecl GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Expr ----------------------------------- +deriving instance Data (FieldLabelStrings GhcPs) +deriving instance Data (FieldLabelStrings GhcRn) +deriving instance Data (FieldLabelStrings GhcTc) + +deriving instance Data (HsFieldLabel GhcPs) +deriving instance Data (HsFieldLabel GhcRn) +deriving instance Data (HsFieldLabel GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsPragE p) deriving instance Data (HsPragE GhcPs) deriving instance Data (HsPragE GhcRn) @@ -292,30 +308,46 @@ deriving instance Data (HsCmdTop GhcRn) deriving instance Data (HsCmdTop GhcTc) -- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) -deriving instance (Data body) => Data (MatchGroup GhcPs body) -deriving instance (Data body) => Data (MatchGroup GhcRn body) -deriving instance (Data body) => Data (MatchGroup GhcTc body) +deriving instance Data (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (MatchGroup GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (MatchGroup GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (MatchGroup GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (MatchGroup GhcTc (LocatedA (HsCmd GhcTc))) -- deriving instance (DataIdLR p p,Data body) => Data (Match p body) -deriving instance (Data body) => Data (Match GhcPs body) -deriving instance (Data body) => Data (Match GhcRn body) -deriving instance (Data body) => Data (Match GhcTc body) +deriving instance Data (Match GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (Match GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (Match GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (Match GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (Match GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (Match GhcTc (LocatedA (HsCmd GhcTc))) -- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) -deriving instance (Data body) => Data (GRHSs GhcPs body) -deriving instance (Data body) => Data (GRHSs GhcRn body) -deriving instance (Data body) => Data (GRHSs GhcTc body) +deriving instance Data (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (GRHSs GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (GRHSs GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (GRHSs GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (GRHSs GhcTc (LocatedA (HsCmd GhcTc))) -- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) -deriving instance (Data body) => Data (GRHS GhcPs body) -deriving instance (Data body) => Data (GRHS GhcRn body) -deriving instance (Data body) => Data (GRHS GhcTc body) +deriving instance Data (GRHS GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (GRHS GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (GRHS GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (GRHS GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (GRHS GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (GRHS GhcTc (LocatedA (HsCmd GhcTc))) -- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) -deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body) -deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) -deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) -deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) +deriving instance Data (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))) +deriving instance Data (StmtLR GhcPs GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (StmtLR GhcRn GhcRn (LocatedA (HsExpr GhcRn))) +deriving instance Data (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))) +deriving instance Data (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs))) +deriving instance Data (StmtLR GhcPs GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (StmtLR GhcRn GhcRn (LocatedA (HsCmd GhcRn))) +deriving instance Data (StmtLR GhcTc GhcTc (LocatedA (HsCmd GhcTc))) deriving instance Data RecStmtTc @@ -394,7 +426,8 @@ deriving instance Data ConPatTc deriving instance Data ListPatTc --- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) +deriving instance (Data a, Data b) => Data (HsRecField' a b) + deriving instance (Data body) => Data (HsRecFields GhcPs body) deriving instance (Data body) => Data (HsRecFields GhcRn body) deriving instance (Data body) => Data (HsRecFields GhcTc body) @@ -452,9 +485,10 @@ deriving instance Data thing => Data (HsScaled GhcPs thing) deriving instance Data thing => Data (HsScaled GhcRn thing) deriving instance Data thing => Data (HsScaled GhcTc thing) -deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs))) -deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn))) -deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind GhcTc))) +deriving instance (Data a, Data b) => Data (HsArg a b) +-- deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs))) +-- deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn))) +-- deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind GhcTc))) -- deriving instance (DataIdLR p p) => Data (ConDeclField p) deriving instance Data (ConDeclField GhcPs) @@ -487,7 +521,12 @@ deriving instance Eq (IE GhcPs) deriving instance Eq (IE GhcRn) deriving instance Eq (IE GhcTc) - -- --------------------------------------------------------------------- deriving instance Data XXExprGhcTc + +-- --------------------------------------------------------------------- + +deriving instance Data XViaStrategyPs + +-- --------------------------------------------------------------------- diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 406f9d72a5..f6ae038745 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -24,6 +24,7 @@ module GHC.Hs.Pat ( Pat(..), LPat, + ApiAnnSumPat(..), ConPatTc (..), CoPat (..), ListPatTc(..), @@ -46,13 +47,14 @@ module GHC.Hs.Pat ( collectEvVarsPat, collectEvVarsPats, - pprParendLPat, pprConArgs + pprParendLPat, pprConArgs, + pprLPat ) where import GHC.Prelude import Language.Haskell.Syntax.Pat -import Language.Haskell.Syntax.Expr (SyntaxExpr) +import Language.Haskell.Syntax.Expr (HsExpr, SyntaxExpr) import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice) @@ -60,6 +62,7 @@ import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice) import GHC.Hs.Binds import GHC.Hs.Lit import Language.Haskell.Syntax.Extension +import GHC.Parser.Annotation import GHC.Hs.Extension import GHC.Hs.Type import GHC.Tc.Types.Evidence @@ -81,6 +84,7 @@ import GHC.Data.Maybe import GHC.Types.Name (Name) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt +import Data.Data data ListPatTc @@ -93,46 +97,56 @@ type instance XWildPat GhcRn = NoExtField type instance XWildPat GhcTc = Type type instance XVarPat (GhcPass _) = NoExtField -type instance XLazyPat (GhcPass _) = NoExtField -type instance XAsPat (GhcPass _) = NoExtField -type instance XParPat (GhcPass _) = NoExtField -type instance XBangPat (GhcPass _) = NoExtField + +type instance XLazyPat GhcPs = ApiAnn -- For '~' +type instance XLazyPat GhcRn = NoExtField +type instance XLazyPat GhcTc = NoExtField + +type instance XAsPat GhcPs = ApiAnn -- For '@' +type instance XAsPat GhcRn = NoExtField +type instance XAsPat GhcTc = NoExtField + +type instance XParPat (GhcPass _) = ApiAnn' AnnParen + +type instance XBangPat GhcPs = ApiAnn -- For '!' +type instance XBangPat GhcRn = NoExtField +type instance XBangPat GhcTc = NoExtField -- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap -- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for -- `SyntaxExpr` -type instance XListPat GhcPs = NoExtField +type instance XListPat GhcPs = ApiAnn' AnnList type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) type instance XListPat GhcTc = ListPatTc -type instance XTuplePat GhcPs = NoExtField +type instance XTuplePat GhcPs = ApiAnn type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XConPat GhcPs = NoExtField -type instance XConPat GhcRn = NoExtField -type instance XConPat GhcTc = ConPatTc - -type instance XSumPat GhcPs = NoExtField +type instance XSumPat GhcPs = ApiAnn' ApiAnnSumPat type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XViewPat GhcPs = NoExtField +type instance XConPat GhcPs = ApiAnn +type instance XConPat GhcRn = NoExtField +type instance XConPat GhcTc = ConPatTc + +type instance XViewPat GhcPs = ApiAnn type instance XViewPat GhcRn = NoExtField type instance XViewPat GhcTc = Type type instance XSplicePat (GhcPass _) = NoExtField type instance XLitPat (GhcPass _) = NoExtField -type instance XNPat GhcPs = NoExtField -type instance XNPat GhcRn = NoExtField +type instance XNPat GhcPs = ApiAnn +type instance XNPat GhcRn = ApiAnn type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = NoExtField +type instance XNPlusKPat GhcPs = ApiAnn type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = NoExtField +type instance XSigPat GhcPs = ApiAnn type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type @@ -145,6 +159,18 @@ type instance ConLikeP GhcPs = RdrName -- IdP GhcPs type instance ConLikeP GhcRn = Name -- IdP GhcRn type instance ConLikeP GhcTc = ConLike +type instance XHsRecField _ = ApiAnn + +-- --------------------------------------------------------------------- + +-- API Annotations types + +data ApiAnnSumPat = ApiAnnSumPat + { sumPatParens :: [AddApiAnn] + , sumPatVbarsBefore :: [AnnAnchor] + , sumPatVbarsAfter :: [AnnAnchor] + } deriving Data + -- --------------------------------------------------------------------- -- | This is the extension field for ConPat, added after typechecking @@ -217,6 +243,9 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat +pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc +pprLPat (L _ e) = pprPat e + -- | Print with type info if -dppr-debug is on pprPatBndr :: OutputableBndr name => name -> SDoc pprPatBndr var @@ -263,13 +292,13 @@ pprPat (ParPat _ pat) = parens (ppr pat) pprPat (LitPat _ s) = ppr s pprPat (NPat _ l Nothing _) = ppr l pprPat (NPat _ l (Just _) _) = char '-' <> ppr l -pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] +pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr_n, char '+', ppr k] + where ppr_n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n pprPat (SplicePat _ splice) = pprSplice splice -pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr_ty - where ppr_ty = case ghcPass @p of - GhcPs -> ppr ty - GhcRn -> ppr ty - GhcTc -> ppr ty +pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat _ pats) = brackets (interpp'SP pats) pprPat (TuplePat _ pats bx) -- Special-case unary boxed tuples so that they are pretty-printed as @@ -286,10 +315,10 @@ pprPat (ConPat { pat_con = con } ) = case ghcPass @p of - GhcPs -> regular - GhcRn -> regular + GhcPs -> pprUserCon (unLoc con) details + GhcRn -> pprUserCon (unLoc con) details GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case - False -> regular + False -> pprUserCon (unLoc con) details True -> -- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an -- error message, and we want to make sure it prints nicely @@ -301,9 +330,6 @@ pprPat (ConPat { pat_con = con , cpt_dicts = dicts , cpt_binds = binds } = ext - where - regular :: OutputableBndr (ConLikeP (GhcPass p)) => SDoc - regular = pprUserCon (unLoc con) details pprPat (XPat ext) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811 @@ -316,13 +342,14 @@ pprPat (XPat ext) = case ghcPass @p of else pprPat pat where CoPat co pat _ = ext -pprUserCon :: (OutputableBndr con, OutputableBndrId p) +pprUserCon :: (OutputableBndr con, OutputableBndrId p, + Outputable (Anno (IdGhcP p))) => con -> HsConPatDetails (GhcPass p) -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details - -pprConArgs :: (OutputableBndrId p) +pprConArgs :: (OutputableBndrId p, + Outputable (Anno (IdGhcP p))) => HsConPatDetails (GhcPass p) -> SDoc pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats) where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs) @@ -342,23 +369,23 @@ mkPrefixConPat :: DataCon -> [LPat GhcTc] -> [Type] -> LPat GhcTc -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys - = noLoc $ ConPat { pat_con = noLoc (RealDataCon dc) - , pat_args = PrefixCon [] pats - , pat_con_ext = ConPatTc - { cpt_tvs = [] - , cpt_dicts = [] - , cpt_binds = emptyTcEvBinds - , cpt_arg_tys = tys - , cpt_wrap = idHsWrapper - } - } + = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc) + , pat_args = PrefixCon [] pats + , pat_con_ext = ConPatTc + { cpt_tvs = [] + , cpt_dicts = [] + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = tys + , cpt_wrap = idHsWrapper + } + } mkNilPat :: Type -> LPat GhcTc mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] mkCharLitPat :: SourceText -> Char -> LPat GhcTc mkCharLitPat src c = mkPrefixConPat charDataCon - [noLoc $ LitPat noExtField (HsCharPrim src c)] [] + [noLocA $ LitPat noExtField (HsCharPrim src c)] [] {- ************************************************************************ @@ -611,7 +638,7 @@ parenthesizePat :: IsPass p -> LPat (GhcPass p) -> LPat (GhcPass p) parenthesizePat p lpat@(L loc pat) - | patNeedsParens p pat = L loc (ParPat noExtField lpat) + | patNeedsParens p pat = L loc (ParPat noAnn lpat) | otherwise = lpat {- @@ -648,3 +675,24 @@ collectEvVarsPat pat = SigPat _ p _ -> collectEvVarsLPat p XPat (CoPat _ p _) -> collectEvVarsPat p _other_pat -> emptyBag + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsOverLit (GhcPass p)) = SrcSpan +type instance Anno ConLike = SrcSpanAnnN + +type instance Anno (HsRecField' p arg) = SrcSpanAnnA +type instance Anno (HsRecField' (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA +type instance Anno (HsRecField (GhcPass p) arg) = SrcSpanAnnA + +-- type instance Anno (HsRecUpdField p) = SrcSpanAnnA +type instance Anno (HsRecField' (AmbiguousFieldOcc p) (LocatedA (HsExpr p))) = SrcSpanAnnA + +type instance Anno (AmbiguousFieldOcc GhcTc) = SrcSpanAnnA diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot index be8bcdf72f..f128e6d4ea 100644 --- a/compiler/GHC/Hs/Pat.hs-boot +++ b/compiler/GHC/Hs/Pat.hs-boot @@ -12,4 +12,6 @@ import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) import Language.Haskell.Syntax.Pat -instance OutputableBndrId p => Outputable (Pat (GhcPass p)) +instance (OutputableBndrId p) => Outputable (Pat (GhcPass p)) + +pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc diff --git a/compiler/GHC/Hs/Stats.hs b/compiler/GHC/Hs/Stats.hs index cb990f9adf..bd3e2e6b6d 100644 --- a/compiler/GHC/Hs/Stats.hs +++ b/compiler/GHC/Hs/Stats.hs @@ -137,7 +137,7 @@ ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = impor data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs - , dd_derivs = L _ derivs}}) + , dd_derivs = derivs}}) = ( length cs , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) 0 derivs ) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 0e67a4a94e..4409756958 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] - -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] + -- in module Language.Haskell.Syntax.Extension {-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId @@ -26,7 +29,7 @@ module GHC.Hs.Type ( hsLinear, hsUnrestricted, isUnrestricted, HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, - HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, + HsForAllTelescope(..), ApiAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, HsWildCardBndrs(..), @@ -94,6 +97,7 @@ import {-# SOURCE #-} GHC.Hs.Expr ( pprSplice ) import Language.Haskell.Syntax.Extension import GHC.Hs.Extension +import GHC.Parser.Annotation import GHC.Types.Id ( Id ) import GHC.Types.SourceText @@ -107,10 +111,11 @@ import GHC.Hs.Doc import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable -import GHC.Parser.Annotation import Data.Maybe +import qualified Data.Semigroup as S + {- ************************************************************************ * * @@ -122,7 +127,7 @@ import Data.Maybe getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p) getBangType (L _ (HsBangTy _ _ lty)) = lty getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) = - addCLoc lty lds (HsDocTy x lty lds) + addCLocA lty lds (HsDocTy x lty lds) getBangType lty = lty getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang @@ -139,13 +144,19 @@ getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) -} fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p) -fromMaybeContext mctxt = unLoc $ fromMaybe (noLoc []) mctxt +fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt -type instance XHsForAllVis (GhcPass _) = NoExtField -type instance XHsForAllInvis (GhcPass _) = NoExtField +type instance XHsForAllVis (GhcPass _) = ApiAnnForallTy + -- Location of 'forall' and '->' +type instance XHsForAllInvis (GhcPass _) = ApiAnnForallTy + -- Location of 'forall' and '.' type instance XXHsForAllTelescope (GhcPass _) = NoExtCon +type ApiAnnForallTy = ApiAnn' (AddApiAnn, AddApiAnn) + -- ^ Location of 'forall' and '->' for HsForAllVis + -- Location of 'forall' and '.' for HsForAllInvis + type HsQTvsRn = [Name] -- Implicit variables -- For example, in data T (a :: k1 -> k2) = ... -- the 'a' is explicit while 'k1', 'k2' are implicit @@ -156,15 +167,15 @@ type instance XHsQTvs GhcTc = HsQTvsRn type instance XXLHsQTyVars (GhcPass _) = NoExtCon -mkHsForAllVisTele :: +mkHsForAllVisTele ::ApiAnnForallTy -> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p) -mkHsForAllVisTele vis_bndrs = - HsForAllVis { hsf_xvis = noExtField, hsf_vis_bndrs = vis_bndrs } +mkHsForAllVisTele an vis_bndrs = + HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs } -mkHsForAllInvisTele :: - [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p) -mkHsForAllInvisTele invis_bndrs = - HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs } +mkHsForAllInvisTele :: ApiAnnForallTy + -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p) +mkHsForAllInvisTele an invis_bndrs = + HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs } mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } @@ -179,7 +190,7 @@ type instance XHsOuterImplicit GhcPs = NoExtField type instance XHsOuterImplicit GhcRn = [Name] type instance XHsOuterImplicit GhcTc = [TyVar] -type instance XHsOuterExplicit GhcPs _ = NoExtField +type instance XHsOuterExplicit GhcPs _ = ApiAnnForallTy type instance XHsOuterExplicit GhcRn _ = NoExtField type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag] @@ -200,8 +211,8 @@ type instance XXHsPatSigType (GhcPass _) = NoExtCon type instance XHsSig (GhcPass _) = NoExtField type instance XXHsSigType (GhcPass _) = NoExtCon -hsSigWcType :: LHsSigWcType pass -> LHsType pass -hsSigWcType = sig_body . unLoc . hswc_body +hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p +hsSigWcType = sig_body . unXRec @p . hswc_body dropWildCards :: LHsSigWcType pass -> LHsSigType pass -- Drop the wildcard part of a LHsSigWcType @@ -219,20 +230,22 @@ hsOuterExplicitBndrs (HsOuterImplicit{}) = [] mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField} -mkHsOuterExplicit :: [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs -mkHsOuterExplicit bndrs = HsOuterExplicit { hso_xexplicit = noExtField - , hso_bndrs = bndrs } +mkHsOuterExplicit :: ApiAnnForallTy -> [LHsTyVarBndr flag GhcPs] + -> HsOuterTyVarBndrs flag GhcPs +mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an + , hso_bndrs = bndrs } mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs mkHsImplicitSigType body = HsSig { sig_ext = noExtField , sig_bndrs = mkHsOuterImplicit, sig_body = body } -mkHsExplicitSigType :: [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs +mkHsExplicitSigType :: ApiAnnForallTy + -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs -> HsSigType GhcPs -mkHsExplicitSigType bndrs body = +mkHsExplicitSigType an bndrs body = HsSig { sig_ext = noExtField - , sig_bndrs = mkHsOuterExplicit bndrs, sig_body = body } + , sig_bndrs = mkHsOuterExplicit an bndrs, sig_body = body } mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing mkHsWildCardBndrs x = HsWC { hswc_body = x @@ -248,8 +261,8 @@ mkEmptyWildCardBndrs x = HsWC { hswc_body = x -------------------------------------------------- -type instance XUserTyVar (GhcPass _) = NoExtField -type instance XKindedTyVar (GhcPass _) = NoExtField +type instance XUserTyVar (GhcPass _) = ApiAnn +type instance XKindedTyVar (GhcPass _) = ApiAnn type instance XXTyVarBndr (GhcPass _) = NoExtCon @@ -274,17 +287,17 @@ instance NamedThing (HsTyVarBndr flag GhcRn) where type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField -type instance XTyVar (GhcPass _) = NoExtField +type instance XTyVar (GhcPass _) = ApiAnn type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = NoExtField -type instance XListTy (GhcPass _) = NoExtField -type instance XTupleTy (GhcPass _) = NoExtField -type instance XSumTy (GhcPass _) = NoExtField +type instance XFunTy (GhcPass _) = ApiAnn' TrailingAnn -- For the AnnRarrow or AnnLolly +type instance XListTy (GhcPass _) = ApiAnn' AnnParen +type instance XTupleTy (GhcPass _) = ApiAnn' AnnParen +type instance XSumTy (GhcPass _) = ApiAnn' AnnParen type instance XOpTy (GhcPass _) = NoExtField -type instance XParTy (GhcPass _) = NoExtField -type instance XIParamTy (GhcPass _) = NoExtField +type instance XParTy (GhcPass _) = ApiAnn' AnnParen +type instance XIParamTy (GhcPass _) = ApiAnn type instance XStarTy (GhcPass _) = NoExtField -type instance XKindSig (GhcPass _) = NoExtField +type instance XKindSig (GhcPass _) = ApiAnn type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives @@ -292,15 +305,18 @@ type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = NoExtField type instance XSpliceTy GhcTc = Kind -type instance XDocTy (GhcPass _) = NoExtField -type instance XBangTy (GhcPass _) = NoExtField -type instance XRecTy (GhcPass _) = NoExtField +type instance XDocTy (GhcPass _) = ApiAnn +type instance XBangTy (GhcPass _) = ApiAnn + +type instance XRecTy GhcPs = ApiAnn' AnnList +type instance XRecTy GhcRn = NoExtField +type instance XRecTy GhcTc = NoExtField -type instance XExplicitListTy GhcPs = NoExtField +type instance XExplicitListTy GhcPs = ApiAnn type instance XExplicitListTy GhcRn = NoExtField type instance XExplicitListTy GhcTc = Kind -type instance XExplicitTupleTy GhcPs = NoExtField +type instance XExplicitTupleTy GhcPs = ApiAnn type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind] @@ -312,10 +328,10 @@ type instance XXType (GhcPass _) = HsCoreTy oneDataConHsTy :: HsType GhcRn -oneDataConHsTy = HsTyVar noExtField NotPromoted (noLoc oneDataConName) +oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName) manyDataConHsTy :: HsType GhcRn -manyDataConHsTy = HsTyVar noExtField NotPromoted (noLoc manyDataConName) +manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName) isUnrestricted :: HsArrow GhcRn -> Bool isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName @@ -325,9 +341,9 @@ isUnrestricted _ = False -- erases the information of whether the programmer wrote an explicit -- multiplicity or a shorthand. arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn -arrowToHsType (HsUnrestrictedArrow _) = noLoc manyDataConHsTy -arrowToHsType (HsLinearArrow _) = noLoc oneDataConHsTy -arrowToHsType (HsExplicitMult _ p) = p +arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy +arrowToHsType (HsLinearArrow _ _) = noLocA oneDataConHsTy +arrowToHsType (HsExplicitMult _ _ p) = p instance (OutputableBndrId pass) => @@ -337,10 +353,10 @@ instance -- See #18846 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc pprHsArrow (HsUnrestrictedArrow _) = arrow -pprHsArrow (HsLinearArrow _) = lollipop -pprHsArrow (HsExplicitMult _ p) = (mulArrow (ppr p)) +pprHsArrow (HsLinearArrow _ _) = lollipop +pprHsArrow (HsExplicitMult _ _ p) = (mulArrow (ppr p)) -type instance XConDeclField (GhcPass _) = NoExtField +type instance XConDeclField (GhcPass _) = ApiAnn type instance XXConDeclField (GhcPass _) = NoExtCon instance OutputableBndrId p @@ -387,10 +403,10 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs , hsq_explicit = tvs }) = kvs ++ hsLTyVarNames tvs -hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p)) -hsLTyVarLocName = mapLoc hsTyVarName +hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p)) +hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a) -hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] +hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Get the kind signature of a type, ignoring parentheses: @@ -427,13 +443,14 @@ ignoreParens ty = ty mkAnonWildCardTy :: HsType GhcPs mkAnonWildCardTy = HsWildCardTy noExtField -mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) +mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN) + => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p)) -> LHsType (GhcPass p) -> HsType (GhcPass p) mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2 mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy t1 t2 - = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) + = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) @@ -442,7 +459,7 @@ mkHsAppTys = foldl' mkHsAppTy mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppKindTy ext ty k - = addCLoc ty k (HsAppKindTy ext ty k) + = addCLocAA ty k (HsAppKindTy ext ty k) {- ************************************************************************ @@ -459,30 +476,41 @@ mkHsAppKindTy ext ty k -- It returns API Annotations for any parens removed splitHsFunType :: LHsType (GhcPass p) - -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn]) -splitHsFunType ty = go ty [] + -> ( [AddApiAnn], ApiAnnComments -- The locations of any parens and + -- comments discarded + , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p)) +splitHsFunType ty = go ty where - go (L l (HsParTy _ ty)) anns - = go ty (anns ++ mkParensApiAnn l) - - go (L _ (HsFunTy _ mult x y)) anns - | (args, res, anns') <- go y anns - = (HsScaled mult x:args, res, anns') - - go other anns = ([], other, anns) + go (L l (HsParTy an ty)) + = let + (anns, cs, args, res) = splitHsFunType ty + anns' = anns ++ annParen2AddApiAnn an + cs' = cs S.<> apiAnnComments (ann l) S.<> apiAnnComments an + in (anns', cs', args, res) + + go (L ll (HsFunTy (ApiAnn _ an cs) mult x y)) + | (anns, csy, args, res) <- splitHsFunType y + = (anns, csy S.<> apiAnnComments (ann ll), HsScaled mult x':args, res) + where + (L (SrcSpanAnn a l) t) = x + an' = addTrailingAnnToA l an cs a + x' = L (SrcSpanAnn an' l) t + + go other = ([], noCom, [], other) -- | Retrieve the name of the \"head\" of a nested type application. -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more -- thorough. The purpose of this function is to examine instance heads, so it -- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.). -hsTyGetAppHead_maybe :: LHsType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) +hsTyGetAppHead_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN) + => LHsType (GhcPass p) + -> Maybe (LocatedN (IdP (GhcPass p))) hsTyGetAppHead_maybe = go where go (L _ (HsTyVar _ _ ln)) = Just ln go (L _ (HsAppTy _ l _)) = go l go (L _ (HsAppKindTy _ t _)) = go t - go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) + go (L _ (HsOpTy _ _ ln _)) = Just ln go (L _ (HsParTy _ t)) = go t go (L _ (HsKindSig _ t _)) = go t go _ = Nothing @@ -492,8 +520,8 @@ hsTyGetAppHead_maybe = go -- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'. lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan lhsTypeArgSrcSpan arg = case arg of - HsValArg tm -> getLoc tm - HsTypeArg at ty -> at `combineSrcSpans` getLoc ty + HsValArg tm -> getLocA tm + HsTypeArg at ty -> at `combineSrcSpans` getLocA ty HsArgPar sp -> sp -------------------------------- @@ -506,27 +534,27 @@ lhsTypeArgSrcSpan arg = case arg of -- type (parentheses and all) from them. splitLHsPatSynTy :: LHsSigType (GhcPass p) - -> ( [LHsTyVarBndr Specificity (NoGhcTc (GhcPass p))] -- universals - , Maybe (LHsContext (GhcPass p)) -- required constraints - , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials - , Maybe (LHsContext (GhcPass p)) -- provided constraints - , LHsType (GhcPass p)) -- body type + -> ( [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))] -- universals + , Maybe (LHsContext (GhcPass p)) -- required constraints + , [LHsTyVarBndr Specificity (GhcPass p)] -- existentials + , Maybe (LHsContext (GhcPass p)) -- provided constraints + , LHsType (GhcPass p)) -- body type splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) where - split_sig_ty :: - LHsSigType (GhcPass p) - -> ([LHsTyVarBndr Specificity (NoGhcTc (GhcPass p))], LHsType (GhcPass p)) - split_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = + -- split_sig_ty :: + -- LHsSigType (GhcPass p) + -- -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], LHsType (GhcPass p)) + split_sig_ty (L _ HsSig{sig_bndrs = outer_bndrs, sig_body = body}) = case outer_bndrs of -- NB: Use ignoreParens here in order to be consistent with the use of -- splitLHsForAllTyInvis below, which also looks through parentheses. HsOuterImplicit{} -> ([], ignoreParens body) HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body) - (univs, ty1) = split_sig_ty ty - (reqs, ty2) = splitLHsQualTy ty1 - (exis, ty3) = splitLHsForAllTyInvis ty2 - (provs, ty4) = splitLHsQualTy ty3 + (univs, ty1) = split_sig_ty ty + (reqs, ty2) = splitLHsQualTy ty1 + ((_an, exis), ty3) = splitLHsForAllTyInvis ty2 + (provs, ty4) = splitLHsQualTy ty3 -- | Decompose a sigma type (of the form @forall <tvs>. context => body@) -- into its constituent parts. @@ -546,8 +574,8 @@ splitLHsSigmaTyInvis :: LHsType (GhcPass p) -> ([LHsTyVarBndr Specificity (GhcPass p)] , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p)) splitLHsSigmaTyInvis ty - | (tvs, ty1) <- splitLHsForAllTyInvis ty - , (ctxt, ty2) <- splitLHsQualTy ty1 + | ((_an,tvs), ty1) <- splitLHsForAllTyInvis ty + , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) -- | Decompose a GADT type into its constituent parts. @@ -592,10 +620,11 @@ splitLHsGadtTy (L _ sig_ty) -- Unlike 'splitLHsSigmaTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis :: - LHsType (GhcPass pass) -> ([LHsTyVarBndr Specificity (GhcPass pass)], LHsType (GhcPass pass)) + LHsType (GhcPass pass) -> ( (ApiAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]) + , LHsType (GhcPass pass)) splitLHsForAllTyInvis ty - | (mb_tvbs, body) <- splitLHsForAllTyInvis_KP (ignoreParens ty) - = (fromMaybe [] mb_tvbs, body) + | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty) + = (fromMaybe (ApiAnnNotUsed,[]) mb_tvbs, body) -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that @@ -609,12 +638,14 @@ splitLHsForAllTyInvis ty -- Unlike 'splitLHsForAllTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis_KP :: - LHsType (GhcPass pass) -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], LHsType (GhcPass pass)) + LHsType (GhcPass pass) -> (Maybe (ApiAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]) + , LHsType (GhcPass pass)) splitLHsForAllTyInvis_KP lty@(L _ ty) = case ty of - HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs } + HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an + , hsf_invis_bndrs = tvs } , hst_body = body } - -> (Just tvs, body) + -> (Just (an, tvs), body) _ -> (Nothing, lty) -- | Decompose a type of the form @context => body@ into its constituent parts. @@ -668,8 +699,9 @@ getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty})) -- | Decompose a type class instance type (of the form -- @forall <tvs>. context => instance_head@) into the @instance_head@ and -- retrieve the underlying class type constructor (if it exists). -getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p))) +getLHsInstDeclClass_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN) + => LHsSigType (GhcPass p) + -> Maybe (LocatedN (IdP (GhcPass p))) -- Works on (LHsSigType GhcPs) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty @@ -774,7 +806,7 @@ type instance XCFieldOcc GhcTc = Id type instance XXFieldOcc (GhcPass _) = NoExtCon -mkFieldOcc :: Located RdrName -> FieldOcc GhcPs +mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs mkFieldOcc rdr = FieldOcc noExtField rdr @@ -795,7 +827,7 @@ instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc -mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs +mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName @@ -821,18 +853,47 @@ ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr ************************************************************************ -} -class OutputableBndrFlag flag where - pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc - -instance OutputableBndrFlag () where - pprTyVarBndr (UserTyVar _ _ n) = ppr n - pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k] - -instance OutputableBndrFlag Specificity where - pprTyVarBndr (UserTyVar _ SpecifiedSpec n) = ppr n - pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr n - pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k] - pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k] +class OutputableBndrFlag flag p where + pprTyVarBndr :: OutputableBndrId p + => HsTyVarBndr flag (GhcPass p) -> SDoc + +instance OutputableBndrFlag () p where + pprTyVarBndr (UserTyVar _ _ n) -- = pprIdP n + = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n + pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr_n, dcolon, ppr k] + where + ppr_n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n + +instance OutputableBndrFlag Specificity p where + pprTyVarBndr (UserTyVar _ SpecifiedSpec n) -- = pprIdP n + = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n + pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr_n + where + ppr_n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n + pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr_n, dcolon, ppr k] + where + ppr_n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n + pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr_n, dcolon, ppr k] + where + ppr_n = case ghcPass @p of + GhcPs -> ppr n + GhcRn -> ppr n + GhcTc -> ppr n instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) = @@ -845,7 +906,9 @@ instance OutputableBndrId p => Outputable (LHsQTyVars (GhcPass p)) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (OutputableBndrFlag flag, OutputableBndrId p) +instance (OutputableBndrFlag flag p, + OutputableBndrFlag flag (NoGhcTcPass p), + OutputableBndrId p) => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where ppr (HsOuterImplicit{hso_ximplicit = imp_tvs}) = text "HsOuterImplicit:" <+> case ghcPass @p of @@ -862,7 +925,7 @@ instance OutputableBndrId p ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) = text "HsForAllInvis:" <+> ppr bndrs -instance (OutputableBndrId p, OutputableBndrFlag flag) +instance (OutputableBndrId p, OutputableBndrFlag flag p) => Outputable (HsTyVarBndr flag (GhcPass p)) where ppr = pprTyVarBndr @@ -870,7 +933,7 @@ instance Outputable thing => Outputable (HsWildCardBndrs (GhcPass p) thing) where ppr (HsWC { hswc_body = ty }) = ppr ty -instance OutputableBndrId p +instance (OutputableBndrId p) => Outputable (HsPatSigType (GhcPass p)) where ppr (HsPS { hsps_body = ty }) = ppr ty @@ -891,7 +954,7 @@ pprHsOuterSigTyVarBndrs :: OutputableBndrId p => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = - pprHsForAll (mkHsForAllInvisTele bndrs) Nothing + pprHsForAll (mkHsForAllInvisTele noAnn bndrs) Nothing -- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ -- only when @-dppr-debug@ is enabled. @@ -906,10 +969,13 @@ pprHsForAll tele cxt HsForAllVis { hsf_vis_bndrs = qtvs } -> pp_forall (space <> arrow) qtvs HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs - pp_forall :: forall flag. OutputableBndrFlag flag => - SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc + pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p) + => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc pp_forall separator qtvs | null qtvs = whenPprDebug (forAllLit <> separator) + -- Note: to fix the PprRecordDotSyntax1 ppr roundtrip test, the <> + -- below needs to be <+>. But it means 94 other test results need to + -- be updated to match. | otherwise = forAllLit <+> interppSP qtvs <> separator pprLHsContext :: (OutputableBndrId p) @@ -929,16 +995,17 @@ pprLHsContextAlways (Just (L _ ctxt)) [L _ ty] -> ppr_mono_ty ty <+> darrow _ -> parens (interpp'SP ctxt) <+> darrow -pprConDeclFields :: (OutputableBndrId p) +pprConDeclFields :: OutputableBndrId p => [LConDeclField (GhcPass p)] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, cd_fld_doc = doc })) = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc - ppr_fld (L _ (XConDeclField x)) = ppr x - ppr_names [n] = ppr n - ppr_names ns = sep (punctuate comma (map ppr ns)) + + ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc + ppr_names [n] = pprPrefixOcc n + ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns)) {- Note [Printing KindedTyVars] @@ -958,7 +1025,8 @@ seems like the Right Thing anyway.) pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc pprHsType ty = ppr_mono_ty ty -ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc +ppr_mono_lty :: OutputableBndrId p + => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc @@ -1138,7 +1206,7 @@ lhsTypeHasLeadingPromotionQuote ty -- returns @ty@. parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) parenthesizeHsType p lty@(L loc ty) - | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty) + | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty) | otherwise = lty -- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint @@ -1152,3 +1220,27 @@ parenthesizeHsContext p lctxt@(L loc ctxt) = [c] -> L loc [parenthesizeHsType p c] _ -> lctxt -- Other contexts are already "parenthesized" by virtue of -- being tuples. +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (BangType (GhcPass p)) = SrcSpanAnnA +type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC +type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsKind (GhcPass p)) = SrcSpanAnnA + +type instance Anno (HsTyVarBndr _flag (GhcPass _)) = SrcSpanAnnA + -- Explicit pass Anno instances needed because of the NoGhcTc field +type instance Anno (HsTyVarBndr _flag GhcPs) = SrcSpanAnnA +type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA +type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA + +type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA +type instance Anno HsIPName = SrcSpan +type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA +type instance Anno (FieldOcc (GhcPass p)) = SrcSpan diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 2745a5944e..7e298b8978 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-| Module : GHC.Hs.Utils Description : Generic helpers for the HsSyn type. @@ -41,7 +42,7 @@ module GHC.Hs.Utils( mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, mkHsDictLet, mkHsLams, - mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, + mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, mkHsCmdIf, @@ -50,6 +51,7 @@ module GHC.Hs.Utils( nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + mkLocatedList, -- * Constructing general big tuples -- $big_tuples @@ -59,6 +61,7 @@ module GHC.Hs.Utils( mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, isInfixFunBind, + spanHsLocaLBinds, -- * Literals mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, @@ -82,6 +85,7 @@ module GHC.Hs.Utils( emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, unitRecStmtTc, + mkLetStmt, -- * Template Haskell mkUntypedSplice, mkTypedSplice, @@ -119,6 +123,7 @@ import GHC.Hs.Type import GHC.Hs.Lit import Language.Haskell.Syntax.Extension import GHC.Hs.Extension +import GHC.Parser.Annotation import GHC.Tc.Types.Evidence import GHC.Core.TyCo.Rep @@ -140,7 +145,6 @@ import GHC.Types.SourceText import GHC.Data.FastString import GHC.Data.Bag import GHC.Settings.Constants -import GHC.Parser.Annotation import GHC.Utils.Misc import GHC.Utils.Outputable @@ -150,6 +154,7 @@ import Data.Either import Data.Function import Data.List ( partition, deleteBy ) import Data.Proxy +import Data.Data (Data) {- ************************************************************************ @@ -165,53 +170,68 @@ just attach 'noSrcSpan' to everything. -- | @e => (e)@ mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsPar e = L (getLoc e) (HsPar noExtField e) - -mkSimpleMatch :: HsMatchContext (NoGhcTc (GhcPass p)) - -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) - -> LMatch (GhcPass p) (Located (body (GhcPass p))) +mkHsPar e = L (getLoc e) (HsPar noAnn e) + +mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA, + Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpan) + => HsMatchContext (NoGhcTc (GhcPass p)) + -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch ctxt pats rhs = L loc $ - Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats - , m_grhss = unguardedGRHSs rhs } + Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats + , m_grhss = unguardedGRHSs (locA loc) rhs noAnn } where loc = case pats of [] -> getLoc rhs - (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) - -unguardedGRHSs :: Located (body (GhcPass p)) - -> GRHSs (GhcPass p) (Located (body (GhcPass p))) -unguardedGRHSs rhs@(L loc _) - = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds) - -unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) - -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] -unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)] - -mkMatchGroup :: ( XMG (GhcPass p) (Located (body (GhcPass p))) ~ NoExtField ) - => Origin -> [Located (Match (GhcPass p) (Located (body (GhcPass p))))] - -> MatchGroup (GhcPass p) (Located (body (GhcPass p))) + (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs) + +unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpan + => SrcSpan -> LocatedA (body (GhcPass p)) -> ApiAnn' GrhsAnn + -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) +unguardedGRHSs loc rhs an + = GRHSs noExtField (unguardedRHS an loc rhs) emptyLocalBinds + +unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpan + => ApiAnn' GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) + -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))] +unguardedRHS an loc rhs = [L loc (GRHS an [] rhs)] + +type AnnoBody p body + = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField + , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL + , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA + ) + +mkMatchGroup :: AnnoBody p body + => Origin + -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup origin matches = MG { mg_ext = noExtField - , mg_alts = mkLocatedList matches + , mg_alts = matches , mg_origin = origin } -mkLocatedList :: [Located a] -> Located [Located a] -mkLocatedList [] = noLoc [] -mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms +mkLocatedList :: Semigroup a => [GenLocated (SrcSpanAnn' a) e2] -> LocatedAn an [GenLocated (SrcSpanAnn' a) e2] +mkLocatedList [] = noLocA [] +mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp = mkHsAppWith addCLoc +mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2) mkHsAppWith :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2) +mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2) mkHsApps :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) -mkHsApps = mkHsAppsWith addCLoc +mkHsApps = mkHsAppsWith addCLocAA mkHsAppsWith :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) @@ -221,7 +241,7 @@ mkHsAppsWith mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn -mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) +mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct) where t_body = hswc_body t paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } @@ -229,15 +249,14 @@ mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: IsPass p - => (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) +mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated - [mkSimpleMatch LambdaExpr pats' body] + (noLocA [mkSimpleMatch LambdaExpr pats' body]) pats' = map (parenthesizePat appPrec) pats mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc @@ -246,14 +265,18 @@ mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking -mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) - -> LMatch (GhcPass p) (Located (body (GhcPass p))) +mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpan, + Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA) + => LPat (GhcPass p) -> (LocatedA (body (GhcPass p))) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc nlHsTyApp fun_id tys - = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id))) + = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id))) nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs @@ -263,16 +286,16 @@ nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs -- So @f x@ becomes @(f x)@, but @3@ stays as @3@. mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsPar le@(L loc e) - | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le) + | hsExprNeedsParens appPrec e = L loc (HsPar noAnn le) | otherwise = le mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) mkParPat lp@(L loc p) - | patNeedsParens appPrec p = L loc (ParPat noExtField lp) + | patNeedsParens appPrec p = L loc (ParPat noAnn lp) | otherwise = lp nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) -nlParPat p = noLoc (ParPat noExtField p) +nlParPat p = noLocA (ParPat noAnn p) ------------------------------- -- These are the bits of syntax that contain rebindable names @@ -281,31 +304,49 @@ nlParPat p = noLoc (ParPat noExtField p) mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs -mkHsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsDo :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsDoAnns :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> ApiAnn' AnnList -> HsExpr GhcPs mkHsComp :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsCompAnns :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> ApiAnn' AnnList + -> HsExpr GhcPs -mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) +mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> ApiAnn + -> Pat GhcPs +mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> ApiAnn -> Pat GhcPs -mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs -- NB: The following functions all use noSyntaxExpr: the generated expressions -- will not work with rebindable syntax if used after the renamer -mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR)) - -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) -mkBodyStmt :: Located (bodyR GhcPs) - -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) -mkPsBindStmt :: LPat GhcPs -> Located (bodyR GhcPs) - -> StmtLR GhcPs GhcPs (Located (bodyR GhcPs)) -mkRnBindStmt :: LPat GhcRn -> Located (bodyR GhcRn) - -> StmtLR GhcRn GhcRn (Located (bodyR GhcRn)) -mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) - -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) - -emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR -emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR -emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR -mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR] +mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR))) +mkBodyStmt :: LocatedA (bodyR GhcPs) + -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs)) +mkPsBindStmt :: ApiAnn -> LPat GhcPs -> LocatedA (bodyR GhcPs) + -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs)) +mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn) + -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn)) +mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc) + -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc)) + +emptyRecStmt :: (Anno [GenLocated + (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) + (StmtLR (GhcPass idL) GhcPs bodyR)] + ~ SrcSpanAnnL) + => StmtLR (GhcPass idL) GhcPs bodyR +emptyRecStmtName :: (Anno [GenLocated + (Anno (StmtLR GhcRn GhcRn bodyR)) + (StmtLR GhcRn GhcRn bodyR)] + ~ SrcSpanAnnL) + => StmtLR GhcRn GhcRn bodyR +emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) +mkRecStmt :: (Anno [GenLocated + (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) + (StmtLR (GhcPass idL) GhcPs bodyR)] + ~ SrcSpanAnnL) + => ApiAnn' AnnList + -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR @@ -313,49 +354,54 @@ mkHsIntegral i = OverLit noExtField (HsIntegral i) noExpr mkHsFractional f = OverLit noExtField (HsFractional f) noExpr mkHsIsString src s = OverLit noExtField (HsIsString src s) noExpr -mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts) -mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) +mkHsDo ctxt stmts = HsDo noAnn ctxt stmts +mkHsDoAnns ctxt stmts anns = HsDo anns ctxt stmts +mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn +mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns where - last_stmt = L (getLoc expr) $ mkLastStmt expr + -- Strip the annotations from the location, they are in the embedded expr + last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsIf c a b = HsIf noExtField c a b +mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> ApiAnn + -> HsExpr GhcPs +mkHsIf c a b anns = HsIf anns c a b -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs -mkHsCmdIf c a b = HsCmdIf noExtField noSyntaxExpr c a b +mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> ApiAnn + -> HsCmd GhcPs +mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b -mkNPat lit neg = NPat noExtField lit neg noSyntaxExpr -mkNPlusKPat id lit - = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr +mkNPat lit neg anns = NPat anns lit neg noSyntaxExpr +mkNPlusKPat id lit anns + = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformStmt :: ApiAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformByStmt :: ApiAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupUsingStmt :: ApiAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupByUsingStmt :: ApiAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt = TransStmt { trS_ext = noExtField - , trS_form = panic "emptyTransStmt: form" - , trS_stmts = [], trS_bndrs = [] - , trS_by = Nothing, trS_using = noLoc noExpr - , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr - , trS_fmap = noExpr } -mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } -mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } -mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } -mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +emptyTransStmt :: ApiAnn -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt anns = TransStmt { trS_ext = anns + , trS_form = panic "emptyTransStmt: form" + , trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLocA noExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noExpr } +mkTransformStmt a ss u = (emptyTransStmt a) { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt a ss u b = (emptyTransStmt a) { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupUsingStmt a ss u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt a ss b u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr mkBodyStmt body = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr -mkPsBindStmt pat body = BindStmt noExtField pat body +mkPsBindStmt ann pat body = BindStmt ann pat body mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultType = unitTy, @@ -364,12 +410,14 @@ mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultMult = Many, xbstc_failOp = Nothing }) pat body -emptyRecStmt' :: forall idL idR body. IsPass idR +emptyRecStmt' :: forall idL idR body . + (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR) => XRecStmt (GhcPass idL) (GhcPass idR) body -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal = RecStmt - { recS_stmts = [], recS_later_ids = [] + { recS_stmts = wrapXRec @(GhcPass idR) [] + , recS_later_ids = [] , recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr , recS_mfix_fn = noSyntaxExpr @@ -382,26 +430,29 @@ unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy , recS_rec_rets = [] , recS_ret_ty = unitTy } -emptyRecStmt = emptyRecStmt' noExtField +emptyRecStmt = emptyRecStmt' noAnn emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking -mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } +mkRecStmt anns stmts = (emptyRecStmt' anns) { recS_stmts = stmts } + +mkLetStmt :: ApiAnn -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) +mkLetStmt anns binds = LetStmt anns binds ------------------------------- -- | A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2 +mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e +mkUntypedSplice :: ApiAnn -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e -mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e +mkTypedSplice :: ApiAnn -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs mkHsQuasiQuote quoter span quote @@ -425,50 +476,55 @@ mkHsCharPrimLit c = HsChar NoSourceText c ************************************************************************ -} -nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) -nlHsVar n = noLoc (HsVar noExtField (noLoc n)) +nlHsVar :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> LHsExpr (GhcPass p) +nlHsVar n = noLocA (HsVar noExtField (noLocA n)) -nl_HsVar :: IdP (GhcPass id) -> HsExpr (GhcPass id) -nl_HsVar n = HsVar noExtField (noLoc n) +nl_HsVar :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> HsExpr (GhcPass p) +nl_HsVar n = HsVar noExtField (noLocA n) -- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc -nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con)) +nlHsDataCon con = noLocA (HsConLikeOut noExtField (RealDataCon con)) nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) -nlHsLit n = noLoc (HsLit noExtField n) +nlHsLit n = noLocA (HsLit noComments n) nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) +nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n))) -nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) -nlVarPat n = noLoc (VarPat noExtField (noLoc n)) +nlVarPat :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> LPat (GhcPass p) +nlVarPat n = noLocA (VarPat noExtField (noLocA n)) nlLitPat :: HsLit GhcPs -> LPat GhcPs -nlLitPat l = noLoc (LitPat noExtField l) +nlLitPat l = noLocA (LitPat noExtField l) nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x)) +nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x)) nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc nlHsSyntaxApps (SyntaxExprTc { syn_expr = fun , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) args - = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" + = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps" mkLHsWrap arg_wraps args)) nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args) -- this function should never be called in scenarios where there is no -- syntax expr -nlHsApps :: IsPass id => IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsApps :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs -nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) -nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f)) - (map ((HsVar noExtField) . noLoc) xs)) +nlHsVarApps :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p) +nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f)) + (map ((HsVar noExtField) . noLocA) xs)) where - mk f a = HsApp noExtField (noLoc f) (noLoc a) + mk f a = HsApp noComments (noLocA f) (noLocA a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) @@ -477,38 +533,38 @@ nlConVarPatName :: Name -> [Name] -> LPat GhcRn nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs -nlInfixConPat con l r = noLoc $ ConPat - { pat_con = noLoc con +nlInfixConPat con l r = noLocA $ ConPat + { pat_con = noLocA con , pat_args = InfixCon (parenthesizePat opPrec l) (parenthesizePat opPrec r) - , pat_con_ext = noExtField + , pat_con_ext = noAnn } nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs -nlConPat con pats = noLoc $ ConPat - { pat_con_ext = noExtField - , pat_con = noLoc con +nlConPat con pats = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA con , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats) } nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn -nlConPatName con pats = noLoc $ ConPat +nlConPatName con pats = noLocA $ ConPat { pat_con_ext = noExtField - , pat_con = noLoc con + , pat_con = noLocA con , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats) } nlNullaryConPat :: RdrName -> LPat GhcPs -nlNullaryConPat con = noLoc $ ConPat - { pat_con_ext = noExtField - , pat_con = noLoc con +nlNullaryConPat con = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA con , pat_args = PrefixCon [] [] } nlWildConPat :: DataCon -> LPat GhcPs -nlWildConPat con = noLoc $ ConPat - { pat_con_ext = noExtField - , pat_con = noLoc $ getRdrName con +nlWildConPat con = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA $ getRdrName con , pat_args = PrefixCon [] $ replicate (dataConSourceArity con) nlWildPat @@ -516,18 +572,18 @@ nlWildConPat con = noLoc $ ConPat -- | Wildcard pattern - after parsing nlWildPat :: LPat GhcPs -nlWildPat = noLoc (WildPat noExtField ) +nlWildPat = noLocA (WildPat noExtField ) -- | Wildcard pattern - after renaming nlWildPatName :: LPat GhcRn -nlWildPatName = noLoc (WildPat noExtField ) +nlWildPatName = noLocA (WildPat noExtField ) nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs -nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) +nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts)) nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) +nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2) nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) @@ -535,80 +591,89 @@ nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs -nlHsLam match = noLoc (HsLam noExtField (mkMatchGroup Generated [match])) -nlHsPar e = noLoc (HsPar noExtField e) +-- AZ:Is this used? +nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match]))) +nlHsPar e = noLocA (HsPar noAnn e) -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is False. (#12080) nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -nlHsIf cond true false = noLoc (HsIf noExtField cond true false) +nlHsIf cond true false = noLocA (HsIf noAnn cond true false) nlHsCase expr matches - = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches)) -nlList exprs = noLoc (ExplicitList noExtField exprs) + = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches))) +nlList exprs = noLocA (ExplicitList noAnn exprs) nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) +nlHsTyVar :: IsSrcSpanAnn p a + => IdP (GhcPass p) -> LHsType (GhcPass p) nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t)) -nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x)) -nlHsFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b) -nlHsParTy t = noLoc (HsParTy noExtField t) +nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t)) +nlHsTyVar x = noLocA (HsTyVar noAnn NotPromoted (noLocA x)) +nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b) +nlHsParTy t = noLocA (HsParTy noAnn t) -nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p) +nlHsTyConApp :: IsSrcSpanAnn p a + => LexicalFixity -> IdP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp fixity tycon tys | Infix <- fixity , HsValArg ty1 : HsValArg ty2 : rest <- tys - = foldl' mk_app (noLoc $ HsOpTy noExtField ty1 (noLoc tycon) ty2) rest + = foldl' mk_app (noLocA $ HsOpTy noExtField ty1 (noLocA tycon) ty2) rest | otherwise = foldl' mk_app (nlHsTyVar tycon) tys where mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) - mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLoc $ HsParTy noExtField fun) arg + mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg -- parenthesize things like `(A + B) C` - mk_app fun (HsValArg ty) = noLoc (HsAppTy noExtField fun (parenthesizeHsType appPrec ty)) - mk_app fun (HsTypeArg _ ki) = noLoc (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki)) - mk_app fun (HsArgPar _) = noLoc (HsParTy noExtField fun) + mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty)) + mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki)) + mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun) nlHsAppKindTy :: LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) nlHsAppKindTy f k - = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) + = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) {- Tuples. All these functions are *pre-typechecker* because they lack types on the tuple. -} -mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) +mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p) + -> LHsExpr (GhcPass p) -- Makes a pre-typechecker boxed tuple, deals with 1 case -mkLHsTupleExpr [e] = e -mkLHsTupleExpr es - = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed +mkLHsTupleExpr [e] _ = e +mkLHsTupleExpr es ext + = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed -mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) -mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) +mkLHsVarTuple :: IsSrcSpanAnn p a + => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p) + -> LHsExpr (GhcPass p) +mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs -nlTuplePat pats box = noLoc (TuplePat noExtField pats box) +nlTuplePat pats box = noLocA (TuplePat noAnn pats box) -missingTupArg :: HsTupArg GhcPs -missingTupArg = Missing noExtField +missingTupArg :: ApiAnn' AnnAnchor -> HsTupArg GhcPs +missingTupArg ann = Missing ann mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn -mkLHsPatTup [] = noLoc $ TuplePat noExtField [] Boxed +mkLHsPatTup [] = noLocA $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed -- | The Big equivalents for the source tuple expressions -mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) -mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) +mkBigLHsVarTup :: IsSrcSpanAnn p a + => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p) + -> LHsExpr (GhcPass p) +mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns -mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) -mkBigLHsTup = mkChunkified mkLHsTupleExpr +mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id) + -> LHsExpr (GhcPass id) +mkBigLHsTup es anns = mkChunkified (\e -> mkLHsTupleExpr e anns) es -- | The Big equivalents for the source tuple patterns mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn @@ -668,16 +733,17 @@ chunkify xs -- | Convert an 'LHsType' to an 'LHsSigType'. hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of - HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an + , hsf_invis_bndrs = bndrs } , hst_body = body } - -> mkHsExplicitSigType bndrs body + -> mkHsExplicitSigType an bndrs body _ -> mkHsImplicitSigType lty -- | Convert an 'LHsType' to an 'LHsSigWcType'. hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType -mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a)) +mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a)) -> [LSig GhcRn] -> NameEnv a mkHsSigEnv get_info sigs @@ -710,8 +776,8 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] mkClassOpSigs sigs = map fiddle sigs where - fiddle (L loc (TypeSig _ nms ty)) - = L loc (ClassOpSig noExtField False nms (dropWildCards ty)) + fiddle (L loc (TypeSig anns nms ty)) + = L loc (ClassOpSig anns False nms (dropWildCards ty)) fiddle sig = sig {- ********************************************************************* @@ -769,20 +835,20 @@ l ************************************************************************ -} -mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] +mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- ^ Not infix, with place holders for coercion and free vars mkFunBind origin fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup origin ms + , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = noExtField , fun_tick = [] } -mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] +mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn -- ^ In Name-land, with empty bind_fvs mkTopFunBind origin fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup origin ms + , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = emptyNameSet -- NB: closed -- binding , fun_tick = [] } @@ -795,11 +861,11 @@ mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_ext = noExtField, var_id = var, var_rhs = rhs } -mkPatSynBind :: Located RdrName -> HsPatSynDetails GhcPs - -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs -mkPatSynBind name details lpat dir = PatSynBind noExtField psb +mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs + -> LPat GhcPs -> HsPatSynDir GhcPs -> ApiAnn -> HsBind GhcPs +mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb where - psb = PSB{ psb_ext = noExtField + psb = PSB{ psb_ext = anns , psb_id = name , psb_args = details , psb_def = lpat @@ -812,6 +878,25 @@ isInfixFunBind (FunBind { fun_matches = MG _ matches _ }) = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches) isInfixFunBind _ = False +-- |Return the 'SrcSpan' encompassing the contents of any enclosed binds +spanHsLocaLBinds :: (Data (HsLocalBinds (GhcPass p))) => HsLocalBinds (GhcPass p) -> SrcSpan +spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan +spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) + = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) + where + bsSpans :: [SrcSpan] + bsSpans = map getLocA $ bagToList bs + sigsSpans :: [SrcSpan] + sigsSpans = map getLocA sigs +spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs))) + = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) + where + bsSpans :: [SrcSpan] + bsSpans = map getLocA $ concatMap (bagToList . snd) bs + sigsSpans :: [SrcSpan] + sigsSpans = map getLocA sigs +spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) + = foldr combineSrcSpans noSrcSpan (map getLocA bs) ------------ -- | Convenience function using 'mkFunBind'. @@ -819,9 +904,9 @@ isInfixFunBind _ = False mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr - = L loc $ mkFunBind Generated (L loc fun) - [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr - (noLoc emptyLocalBinds)] + = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun) + [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr + emptyLocalBinds] -- | Make a prefix, non-strict function 'HsMatchContext' mkPrefixFunRhs :: LIdP p -> HsMatchContext p @@ -834,17 +919,17 @@ mkMatch :: forall p. IsPass p => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) - -> Located (HsLocalBinds (GhcPass p)) + -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) -mkMatch ctxt pats expr lbinds - = noLoc (Match { m_ext = noExtField - , m_ctxt = ctxt - , m_pats = map paren pats - , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) +mkMatch ctxt pats expr binds + = noLocA (Match { m_ext = noAnn + , m_ctxt = ctxt + , m_pats = map paren pats + , m_grhss = GRHSs noExtField (unguardedRHS noAnn noSrcSpan expr) binds }) where - paren :: Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p)) + paren :: LPat (GhcPass p) -> LPat (GhcPass p) paren lp@(L l p) - | patNeedsParens appPrec p = L l (ParPat noExtField lp) + | patNeedsParens appPrec p = L l (ParPat noAnn lp) | otherwise = lp {- @@ -1059,12 +1144,12 @@ collectStmtBinders -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders flag = \case BindStmt _ pat _ -> collectPatBinders flag pat - LetStmt _ binds -> collectLocalBinders flag (unLoc binds) + LetStmt _ binds -> collectLocalBinders flag binds BodyStmt {} -> [] LastStmt {} -> [] ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts - RecStmt { recS_stmts = ss } -> collectLStmtsBinders flag ss + RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss ApplicativeStmt _ args _ -> concatMap collectArgBinders args where collectArgBinders = \case @@ -1255,13 +1340,13 @@ hsTyClForeignBinders tycl_decls foreign_decls `mappend` foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where - getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] + getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name] getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs ------------------- hsLTyClDeclBinders :: IsPass p - => Located (TyClDecl (GhcPass p)) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + => LocatedA (TyClDecl (GhcPass p)) + -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second @@ -1285,7 +1370,8 @@ hsLTyClDeclBinders (L loc (ClassDecl [ L fam_loc fam_name | (L fam_loc (FamilyDecl { fdLName = L _ fam_name })) <- ats ] ++ - [ L mem_loc mem_name | (L mem_loc (ClassOpSig _ False ns _)) <- sigs + [ L mem_loc mem_name + | (L mem_loc (ClassOpSig _ False ns _)) <- sigs , (L _ mem_name) <- ns ] , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) @@ -1294,11 +1380,12 @@ hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) ------------------- -hsForeignDeclsBinders :: forall pass. (UnXRec pass, MapXRec pass) => [LForeignDecl pass] -> [LIdP pass] +hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a) + => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)] -- ^ See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls - = [ mapXRec @pass (const $ unXRec @pass n) fi - | fi@(unXRec @pass -> ForeignImport { fd_name = n }) + = [ L (noAnnSrcSpan (locA decl_loc)) n + | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] @@ -1325,7 +1412,7 @@ getPatSynBinds binds ------------------- hsLInstDeclBinders :: IsPass p => LInstDecl (GhcPass p) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis }})) @@ -1338,7 +1425,7 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty -- | the 'SrcLoc' returned are for the whole declarations, not just the names hsDataFamInstBinders :: IsPass p => DataFamInstDecl (GhcPass p) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders @@ -1347,7 +1434,7 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }}) -- | the 'SrcLoc' returned are for the whole declarations, not just the names hsDataDefnBinders :: IsPass p => HsDataDefn (GhcPass p) - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] @@ -1358,7 +1445,7 @@ type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] hsConDeclsBinders :: forall p. IsPass p => [LConDecl (GhcPass p)] - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful @@ -1366,7 +1453,7 @@ hsConDeclsBinders cons = go id cons where go :: Seen p -> [LConDecl (GhcPass p)] - -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) go _ [] = ([], []) go remSeen (r:rs) -- Don't re-mangle the location of field names, because we don't @@ -1397,7 +1484,7 @@ hsConDeclsBinders cons get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds get_flds_gadt remSeen _ = (remSeen, []) - get_flds :: Seen p -> Located [LConDeclField (GhcPass p)] + get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)] -> (Seen p, [LFieldOcc (GhcPass p)]) get_flds remSeen flds = (remSeen', fld_names) where @@ -1447,27 +1534,27 @@ is used but it's only used for one specific purpose in one place so it seemed easier. -} -lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] +lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] -> [(SrcSpan, [Name])] lStmtsImplicits = hs_lstmts where - hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] + hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] -> [(SrcSpan, [Name])] hs_lstmts = concatMap (hs_stmt . unLoc) - hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) + hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR))) -> [(SrcSpan, [Name])] hs_stmt (BindStmt _ pat _) = lPatImplicits pat hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat - do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts - hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) + do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts + hs_stmt (LetStmt _ binds) = hs_local_binds binds hs_stmt (BodyStmt {}) = [] hs_stmt (LastStmt {}) = [] hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts - hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds hs_local_binds (HsIPBinds {}) = [] @@ -1506,7 +1593,7 @@ lPatImplicits = hs_lpat hs_pat _ = [] - details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] + details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] details _ (PrefixCon _ ps) = hs_lpats ps details n (RecCon fs) = [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] @@ -1521,6 +1608,6 @@ lPatImplicits = hs_lpat , let pat_explicit = maybe True ((i<) . unLoc) (rec_dotdot fs)] - err_loc = maybe (getLoc n) getLoc (rec_dotdot fs) + err_loc = maybe (getLocA n) getLoc (rec_dotdot fs) details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index fafcdb6533..c95595a458 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -403,7 +403,7 @@ dsRule (L loc (HsRule { rd_name = name , rd_tmvs = vars , rd_lhs = lhs , rd_rhs = rhs })) - = putSrcSpanDs loc $ + = putSrcSpanDs (locA loc) $ do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index c4e9a3297c..8017fc65f6 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -297,7 +297,8 @@ matchVarStack (param_id:param_ids) stack_id body = do mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc mkHsEnvStackExpr env_ids stack_id - = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] + = mkLHsTupleExpr [mkLHsVarTuple env_ids noExtField, nlHsVar stack_id] + noExtField -- Translation of arrow abstraction @@ -554,14 +555,17 @@ dsCmd ids local_vars stack_ty res_ty let left_id = HsConLikeOut noExtField (RealDataCon left_con) right_id = HsConLikeOut noExtField (RealDataCon right_con) - left_expr ty1 ty2 e = noLoc $ HsApp noExtField - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLoc $ HsApp noExtField - (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e + left_expr ty1 ty2 e = noLocA $ HsApp noComments + (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e + right_expr ty1 ty2 e = noLocA $ HsApp noComments + (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. + merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr) + -> ([LHsExpr GhcTc], Type, CoreExpr) + -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ merge_branches (builds1, in_ty1, core_exp1) (builds2, in_ty2, core_exp2) = (map (left_expr in_ty1 in_ty2) builds1 ++ @@ -590,7 +594,7 @@ dsCmd ids local_vars stack_ty res_ty dsCmd ids local_vars stack_ty res_ty (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do arg_id <- newSysLocalDs arg_mult arg_ty - let case_cmd = noLoc $ HsCmdCase noExtField (nlHsVar arg_id) mg + let case_cmd = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids -- D; ys |-a cmd : stk --> t @@ -599,8 +603,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) - env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -629,7 +632,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body) dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty (L loc stmts)) env_ids = do - putSrcSpanDs loc $ + putSrcSpanDsA loc $ dsNoLevPoly stmts_ty (text "In the do-command:" <+> ppr do_block) (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids @@ -701,7 +704,7 @@ dsfixCmd DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd - = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty + = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty (text "When desugaring the command:" <+> ppr cmd) ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } @@ -791,7 +794,7 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- ---> premap (\ (xs) -> ((xs), ())) c dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do - putSrcSpanDs loc $ dsNoLevPoly res_ty + putSrcSpanDsA loc $ dsNoLevPoly res_ty (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids @@ -958,7 +961,7 @@ dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do -- arr (\((xs1),(xs2)) -> (xs')) >>> ss' dsCmdStmt ids local_vars out_ids - (RecStmt { recS_stmts = stmts + (RecStmt { recS_stmts = L _ stmts , recS_later_ids = later_ids, recS_rec_ids = rec_ids , recS_ext = RecStmtTc { recS_later_rets = later_rets , recS_rec_rets = rec_rets } }) @@ -1149,10 +1152,10 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" -- List of leaf expressions, with set of variables bound in each -leavesMatch :: LMatch GhcTc (Located (body GhcTc)) - -> [(Located (body GhcTc), IdSet)] +leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc)) + -> [(LocatedA (body GhcTc), IdSet)] leavesMatch (L _ (Match { m_pats = pats - , m_grhss = GRHSs _ grhss (L _ binds) })) + , m_grhss = GRHSs _ grhss binds })) = let defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats) `unionVarSet` @@ -1166,24 +1169,28 @@ leavesMatch (L _ (Match { m_pats = pats -- Replace the leaf commands in a match replaceLeavesMatch - :: Type -- new result type - -> [Located (body' GhcTc)] -- replacement leaf expressions of that type - -> LMatch GhcTc (Located (body GhcTc)) -- the matches of a case command - -> ([Located (body' GhcTc)], -- remaining leaf expressions - LMatch GhcTc (Located (body' GhcTc))) -- updated match + :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc))) + , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc)))) + => Type -- new result type + -> [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type + -> LMatch GhcTc (LocatedA (body GhcTc)) -- the matches of a case command + -> ([LocatedA (body' GhcTc)], -- remaining leaf expressions + LMatch GhcTc (LocatedA (body' GhcTc))) -- updated match replaceLeavesMatch _res_ty leaves (L loc match@(Match { m_grhss = GRHSs x grhss binds })) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds })) + (leaves', L loc (match { m_ext = noAnn, m_grhss = GRHSs x grhss' binds })) replaceLeavesGRHS - :: [Located (body' GhcTc)] -- replacement leaf expressions of that type - -> LGRHS GhcTc (Located (body GhcTc)) -- rhss of a case command - -> ([Located (body' GhcTc)], -- remaining leaf expressions - LGRHS GhcTc (Located (body' GhcTc))) -- updated GRHS + :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc))) + , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc)))) + => [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type + -> LGRHS GhcTc (LocatedA (body GhcTc)) -- rhss of a case command + -> ([LocatedA (body' GhcTc)], -- remaining leaf expressions + LGRHS GhcTc (LocatedA (body' GhcTc))) -- updated GRHS replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _)) = (leaves, L loc (GRHS x stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 6ac30e599a..64114b513f 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -108,7 +108,7 @@ dsTopLHsBinds binds bang_binds = filterBag (isBangedHsBind . unLoc) binds top_level_err desc (L loc bind) - = putSrcSpanDs loc $ + = putSrcSpanDs (locA loc) $ errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)) @@ -125,7 +125,7 @@ dsLHsBinds binds dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBind (L loc bind) = do dflags <- getDynFlags - putSrcSpanDs loc $ dsHsBind dflags bind + putSrcSpanDs (locA loc) $ dsHsBind dflags bind -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 3a8c106b90..dca2b09f7d 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -136,7 +136,7 @@ guessSourceFile binds orig_file = -- Try look for a file generated from a .hsc file to a -- .hs file, by peeking ahead. let top_pos = catMaybes $ foldr (\ (L pos _) rest -> - srcSpanFileName_maybe pos : rest) [] binds + srcSpanFileName_maybe (locA pos) : rest) [] binds in case top_pos of (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name @@ -313,7 +313,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do addPathEntry name $ addTickMatchGroup False (fun_matches funBind) - blackListed <- isBlackListed pos + blackListed <- isBlackListed (locA pos) exported_names <- liftM exports getEnv -- We don't want to generate code for blacklisted positions @@ -326,7 +326,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do tick <- if not blackListed && shouldTickBind density toplev exported simple inline then - bindTick density name pos fvs + bindTick density name (locA pos) fvs else return Nothing @@ -366,14 +366,14 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs -- Allocate the ticks - rhs_tick <- bindTick density name pos fvs + rhs_tick <- bindTick density name (locA pos) fvs let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks patvar_tickss <- case simplePatId of Just{} -> return initial_patvar_tickss Nothing -> do let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs) - patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars + patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars return (zipWith mbCons patvar_ticks (initial_patvar_tickss ++ repeat [])) @@ -424,7 +424,8 @@ addTickLHsExpr e@(L pos e0) = do TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 dont_tick_it = addTickLHsExprNever e -- Add a tick to an expression which is the RHS of an equation or a binding. @@ -441,7 +442,8 @@ addTickLHsExprRHS e@(L pos e0) = do TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 dont_tick_it = addTickLHsExprNever e -- The inner expression of an evaluation context: @@ -468,7 +470,8 @@ addTickLHsExprLetBody e@(L pos e0) = do | otherwise -> tick_it _other -> addTickLHsExprEvalInner e where - tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 dont_tick_it = addTickLHsExprNever e -- version of addTick that does not actually add a tick, @@ -495,13 +498,14 @@ isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprOptAlt oneOfMany (L pos e0) = ifDensity TickForCoverage - (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0) + (allocTickBox (ExpBox oneOfMany) False False (locA pos) + $ addTickHsExpr e0) (addTickLHsExpr (L pos e0)) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addBinTickLHsExpr boxLabel (L pos e0) = ifDensity TickForCoverage - (allocBinTickBox boxLabel pos $ addTickHsExpr e0) + (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0) (addTickLHsExpr (L pos e0)) @@ -574,9 +578,9 @@ addTickHsExpr (HsMultiIf ty alts) = do { let isOneOfMany = case alts of [_] -> False; _ -> True ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x (L l binds) e) = +addTickHsExpr (HsLet x binds e) = bindLocals (collectLocalBinders CollNoDictBinders binds) $ - liftM2 (HsLet x . L l) + liftM2 (HsLet x) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprLetBody e) addTickHsExpr (HsDo srcloc cxt (L l stmts)) @@ -644,10 +648,10 @@ addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) = liftM (XExpr . ExpansionExpr . HsExpanded a) $ (addTickHsExpr b) -addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) -addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e - ; return (L l (Present x e')) } -addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) +addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) +addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e + ; return (Present x e') } +addTickTupArg (Missing ty) = return (Missing ty) addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) @@ -667,11 +671,11 @@ addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs x guarded' (L l local_binds') + return $ GRHSs x guarded' local_binds' where binders = collectLocalBinders CollNoDictBinders local_binds @@ -689,7 +693,7 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr TickAllFunctions | isLambda -> addPathEntry "\\" $ - allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $ + allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $ addTickHsExpr e0 _otherwise -> addTickLHsExprRHS expr @@ -731,13 +735,13 @@ addTickStmt isGuard (BodyStmt x e bind' guard') = (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x (L l binds)) = - liftM (LetStmt x . L l) +addTickStmt _isGuard (LetStmt x binds) = + liftM (LetStmt x) (addTickHsLocalBinds binds) addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = liftM3 (ParStmt x) (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr)) + (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr)) (addTickSyntaxExpr hpcSrcSpan bindExpr) addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do args' <- mapM (addTickApplicativeArg isGuard) args @@ -752,16 +756,16 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts t_u <- addTickLHsExprRHS using t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr)) + t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr)) return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } addTickStmt isGuard stmt@(RecStmt {}) - = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) + = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt) ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) @@ -783,7 +787,7 @@ addTickApplicativeArg isGuard (op, arg) = addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = (ApplicativeArgMany x) <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret)) + <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) <*> addTickLPat pat <*> pure ctxt @@ -832,7 +836,7 @@ addTickIPBind (IPBind x nm e) = -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do - x' <- fmap unLoc (addTickLHsExpr (L pos x)) + x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x)) return $ syn { syn_expr = x' } addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc @@ -876,9 +880,9 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x (L l binds) c) = +addTickHsCmd (HsCmdLet x binds c) = bindLocals (collectLocalBinders CollNoDictBinders binds) $ - liftM2 (HsCmdLet x . L l) + liftM2 (HsCmdLet x) (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) addTickHsCmd (HsCmdDo srcloc (L l stmts)) @@ -919,11 +923,11 @@ addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = return $ match { m_grhss = gRHSs' } addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = +addTickCmdGRHSs (GRHSs x guarded local_binds) = bindLocals binders $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs x guarded' (L l local_binds') + return $ GRHSs x guarded' local_binds' where binders = collectLocalBinders CollNoDictBinders local_binds @@ -966,15 +970,15 @@ addTickCmdStmt (BodyStmt x c bind' guard') = (addTickLHsCmd c) (addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x (L l binds)) = - liftM (LetStmt x . L l) +addTickCmdStmt (LetStmt x binds) = + liftM (LetStmt x) (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {}) - = do { stmts' <- addTickLCmdStmts (recS_stmts stmt) + = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt) ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' + ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTickCmdStmt ApplicativeStmt{} = panic "ToDo: addTickCmdStmt ApplicativeLastStmt" @@ -987,11 +991,11 @@ addTickHsRecordBinds (HsRecFields fields dd) = do { fields' <- mapM addTickHsRecField fields ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc) - -> TM (LHsRecField' id (LHsExpr GhcTc)) -addTickHsRecField (L l (HsRecField id expr pun)) +addTickHsRecField :: LHsRecField' GhcTc id (LHsExpr GhcTc) + -> TM (LHsRecField' GhcTc id (LHsExpr GhcTc)) +addTickHsRecField (L l (HsRecField x id expr pun)) = do { expr' <- addTickLHsExpr expr - ; return (L l (HsRecField id expr' pun)) } + ; return (L l (HsRecField x id expr' pun)) } addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) = @@ -1185,10 +1189,10 @@ allocTickBox boxLabel countEntries topOnly pos m = (fvs, e) <- getFreeVars m env <- getEnv tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L pos (HsTick noExtField tickish (L pos e))) + return (L (noAnnSrcSpan pos) (HsTick noExtField tickish (L (noAnnSrcSpan pos) e))) ) (do e <- m - return (L pos e) + return (L (noAnnSrcSpan pos) e) ) -- the tick application inherits the source position of its @@ -1248,7 +1252,7 @@ allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) allocBinTickBox boxLabel pos m = do env <- getEnv case tickishType env of - HpcTicks -> do e <- liftM (L pos) m + HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m ifGoodTickSrcSpan pos (mkBinTickBoxHpc boxLabel pos e) (return e) @@ -1264,7 +1268,8 @@ mkBinTickBoxHpc boxLabel pos e = do <*> pure e tick <- HpcTick (this_mod env) <$> addMixEntry (pos,declPath env, [],ExpBox False) - return $ L pos $ HsTick noExtField tick (L pos binTick) + let pos' = noAnnSrcSpan pos + return $ L pos' $ HsTick noExtField tick (L pos' binTick) mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s _) diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index fa278b7983..0dd6267db6 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -25,6 +25,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Tc.Types +import GHC.Parser.Annotation import Control.Applicative import Control.Monad.IO.Class @@ -99,7 +100,7 @@ mkMaps instances decls = -> ( [(Name, HsDocString)] , [(Name, IntMap HsDocString)] ) - mappings (L (RealSrcSpan l _) decl, docStrs) = + mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) = (dm, am) where doc = concatDocs docStrs @@ -115,7 +116,7 @@ mkMaps instances decls = subNs = [ n | (n, _, _) <- subs ] dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs] am = [(n, args) | n <- ns] ++ zip subNs subArgs - mappings (L (UnhelpfulSpan _) _, _) = ([], []) + mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) instanceMap :: Map RealSrcSpan Name instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] @@ -134,8 +135,8 @@ looking at GHC sources). We can assume that commented instances are user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -} - -getMainDeclBinder :: CollectPass (GhcPass p) => HsDecl (GhcPass p) -> [IdP (GhcPass p)] +getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p)) + => HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) = case collectHsBindBinders CollNoDictBinders d of @@ -159,9 +160,9 @@ sigNameNoLoc _ = [] -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap. -getInstLoc :: InstDecl (GhcPass p) -> SrcSpan +getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case - ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc ty + ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA ty -- The Names of data and type family instances have their SrcSpan's attached -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have -- its SrcSpan attached here: @@ -169,12 +170,12 @@ getInstLoc = \case -- type instance Foo Int = Bool -- ^^^ DataFamInstD _ (DataFamInstDecl - { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> l + { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason. TyFamInstD _ (TyFamInstDecl - { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> l + { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data @@ -187,7 +188,7 @@ subordinates instMap decl = case decl of DataFamInstDecl { dfid_eqn = FamEqn { feqn_tycon = L l _ , feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d - [ (n, [], IM.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn + [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn InstD _ (DataFamInstD _ (DataFamInstDecl d)) -> dataSubs (feqn_rhs d) @@ -215,7 +216,8 @@ subordinates instMap decl = case decl of derivs = [ (instName, [unLoc doc], IM.empty) | (l, doc) <- concatMap (extract_deriv_clause_tys . deriv_clause_tys . unLoc) $ - unLoc $ dd_derivs dd + -- unLoc $ dd_derivs dd + dd_derivs dd , Just instName <- [lookupSrcSpan l instMap] ] extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)] @@ -228,7 +230,7 @@ subordinates instMap decl = case decl of extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) = case ty of -- deriving (C a {- ^ Doc comment -}) - HsDocTy _ _ doc -> Just (l, doc) + HsDocTy _ _ doc -> Just (locA l, doc) _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. @@ -264,7 +266,7 @@ isValD _ = False -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -classDecls class_ = filterDecls . collectDocs . sortLocated $ decls +classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls where decls = docs ++ defs ++ sigs ++ ats docs = mkDecls tcdDocs (DocD noExtField) class_ @@ -312,7 +314,7 @@ sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body) -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] -topDecls = filterClasses . filterDecls . collectDocs . sortLocated . ungroup +topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] @@ -369,12 +371,12 @@ filterDecls = filter (isHandled . unXRec @p . fst) -- | Go through all class declarations and filter their sub-declarations -filterClasses :: forall p doc. (UnXRec p, MapXRec p) => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)] -filterClasses = map (first (mapXRec @p filterClass)) +filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)] +filterClasses = map (first (mapLoc filterClass)) where filterClass (TyClD x c@(ClassDecl {})) = TyClD x $ c { tcdSigs = - filter (liftA2 (||) (isUserSig . unXRec @p) isMinimalLSig) (tcdSigs c) } + filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) } filterClass d = d -- | Was this signature given by the user? @@ -386,10 +388,10 @@ isUserSig _ = False -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor -mkDecls :: (struct -> [Located decl]) +mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct - -> [Located hsDecl] + -> [GenLocated l hsDecl] mkDecls field con = map (mapLoc con) . field -- | Extracts out individual maps of documentation added via Template Haskell's diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 387963827e..1b18176051 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -80,11 +80,11 @@ import Data.Void( absurd ) ************************************************************************ -} -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body -dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $ - dsValBinds binds body -dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body +dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsLocalBinds (EmptyLocalBinds _) body = return body +dsLocalBinds b@(HsValBinds _ binds) body = putSrcSpanDs (spanHsLocaLBinds b) $ + dsValBinds binds body +dsLocalBinds (HsIPBinds _ binds) body = dsIPBinds binds body ------------------------- -- caller sets location @@ -121,7 +121,7 @@ ds_val_bind (NonRecursive, hsbinds) body -- could be dict binds in the 'binds'. (See the notes -- below. Then pattern-match would fail. Urk.) , isUnliftedHsBind bind - = putSrcSpanDs loc $ + = putSrcSpanDs (locA loc) $ -- see Note [Strict binds checks] in GHC.HsToCore.Binds if is_polymorphic bind then errDsCoreExpr (poly_bind_err bind) @@ -249,7 +249,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) -- ; return core_expr } dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr dsLExpr (L loc e) = - putSrcSpanDs loc $ dsExpr e + putSrcSpanDsA loc $ dsExpr e -- | Variant of 'dsLExpr' that ensures that the result is not levity -- polymorphic. This should be used when the resulting expression will @@ -258,7 +258,7 @@ dsLExpr (L loc e) = -- See Note [Levity polymorphism invariants] in "GHC.Core" dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsLExprNoLP (L loc e) - = putSrcSpanDs loc $ + = putSrcSpanDsA loc $ do { e' <- dsExpr e ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) ; return e' } @@ -311,7 +311,7 @@ dsExpr hswrap@(XExpr (WrapExpr (HsWrap co_fn e))) dsExpr (NegApp _ (L loc (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) neg_expr) - = do { expr' <- putSrcSpanDs loc $ do + = do { expr' <- putSrcSpanDsA loc $ do { warnAboutOverflowedOverLit (lit { ol_val = HsIntegral (negateIntegralLit i) }) ; dsOverLit lit } @@ -356,12 +356,12 @@ converting to core it must become a CO. -} dsExpr (ExplicitTuple _ tup_args boxity) - = do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty))) + = do { let go (lam_vars, args) (Missing (Scaled mult ty)) -- For every missing expression, we need -- another lambda in the desugaring. = do { lam_var <- newSysLocalDsNoLP mult ty ; return (lam_var : lam_vars, Var lam_var : args) } - go (lam_vars, args) (L _ (Present _ expr)) + go (lam_vars, args) (Present _ expr) -- Expressions that are present don't generate -- lambdas, just arguments. = do { core_expr <- dsLExprNoLP expr @@ -411,7 +411,7 @@ dsExpr (HsMultiIf res_ty alts) = mkErrorExpr | otherwise - = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds) + = do { let grhss = GRHSs noExtField alts emptyLocalBinds ; rhss_nablas <- pmcGRHSs IfAlt grhss ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas ; error_expr <- mkErrorExpr @@ -452,7 +452,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do dflags <- getDynFlags let platform = targetPlatform dflags - let (line, col) = case loc of + let (line, col) = case locA loc of RealSrcSpan r _ -> ( srcLocLine $ realSrcSpanStart r , srcLocCol $ realSrcSpanStart r @@ -463,7 +463,7 @@ dsExpr (HsStatic _ expr@(L loc _)) = do , mkIntExprInt platform line, mkIntExprInt platform col ] - putSrcSpanDs loc $ return $ + putSrcSpanDsA loc $ return $ mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] {- @@ -633,7 +633,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; ([discrim_var], matching_code) <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates] - (MG { mg_alts = noLoc alts + (MG { mg_alts = noLocA alts , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty , mg_origin = FromSource }) @@ -687,7 +687,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con) + inst_con = noLocA $ mkHsWrap wrap (HsConLikeOut noExtField con) -- Reconstruct with the WrapId so that unpacking happens wrap = mkWpEvVarApps theta_vars <.> dict_req_wrap <.> @@ -731,16 +731,16 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - pat = noLoc $ ConPat { pat_con = noLoc con - , pat_args = PrefixCon [] $ map nlVarPat arg_ids - , pat_con_ext = ConPatTc - { cpt_tvs = ex_tvs - , cpt_dicts = eqs_vars ++ theta_vars - , cpt_binds = emptyTcEvBinds - , cpt_arg_tys = in_inst_tys - , cpt_wrap = req_wrap - } - } + pat = noLocA $ ConPat { pat_con = noLocA con + , pat_args = PrefixCon [] $ map nlVarPat arg_ids + , pat_con_ext = ConPatTc + { cpt_tvs = ex_tvs + , cpt_dicts = eqs_vars ++ theta_vars + , cpt_binds = emptyTcEvBinds + , cpt_arg_tys = in_inst_tys + , cpt_wrap = req_wrap + } + } ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } {- Note [Scrutinee in Record updates] @@ -813,7 +813,7 @@ ds_prag_expr (HsPragSCC _ _ cc) expr = do count <- goptM Opt_ProfCountEntries let nm = sl_fs cc flavour <- ExprCC <$> getCCIndexDsM nm - Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) + Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True) <$> dsLExpr expr else dsLExpr expr @@ -951,7 +951,7 @@ dsDo ctx stmts = goL stmts where goL [] = panic "dsDo" - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts) go _ (LastStmt _ body _ _) stmts = ASSERT( null stmts ) dsLExpr body @@ -984,11 +984,11 @@ dsDo ctx stmts do_arg (ApplicativeArgOne fail_op pat expr _) = ((pat, fail_op), dsLExpr expr) do_arg (ApplicativeArgMany _ stmts ret pat _) = - ((pat, Nothing), dsDo ctx (stmts ++ [noLoc $ mkLastStmt (noLoc ret)])) + ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)])) ; rhss' <- sequence rhss - ; body' <- dsLExpr $ noLoc $ HsDo body_ty ctx (noLoc stmts) + ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts) ; let match_args (pat, fail_op) (vs,body) = do { var <- selectSimpleMatchVarL Many pat @@ -1006,7 +1006,7 @@ dsDo ctx stmts Nothing -> return expr Just join_op -> dsSyntaxExpr join_op [expr] } - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids + go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op , recS_ext = RecStmtTc @@ -1029,19 +1029,19 @@ dsDo ctx stmts tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats - rets = map noLoc rec_rets + rets = map noLocA rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - mfix_arg = noLoc $ HsLam noExtField - (MG { mg_alts = noLoc [mkSimpleMatch + mfix_arg = noLocA $ HsLam noExtField + (MG { mg_alts = noLocA [mkSimpleMatch LambdaExpr [mfix_pat] body] , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty , mg_origin = Generated }) - mfix_pat = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats - body = noLoc $ HsDo body_ty - ctx (noLoc (rec_stmts ++ [ret_stmt])) + mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats + body = noLocA $ HsDo body_ty + ctx (noLocA (rec_stmts ++ [ret_stmt])) ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets] - ret_stmt = noLoc $ mkLastStmt ret_app + ret_stmt = noLocA $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, -- which ignores the return_op in the LastStmt, -- so we must apply the return_op explicitly diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot index a4e67b994c..ce438dceb9 100644 --- a/compiler/GHC/HsToCore/Expr.hs-boot +++ b/compiler/GHC/HsToCore/Expr.hs-boot @@ -1,5 +1,5 @@ module GHC.HsToCore.Expr where -import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) +import GHC.Hs ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr ) import GHC.HsToCore.Monad ( DsM ) import GHC.Core ( CoreExpr ) import GHC.Hs.Extension ( GhcTc) @@ -7,4 +7,4 @@ import GHC.Hs.Extension ( GhcTc) dsExpr :: HsExpr GhcTc -> DsM CoreExpr dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr +dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 43175c69a3..ba7cd74a89 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -106,7 +106,7 @@ dsForeigns' fos = do (mconcat cs `mappend` fe_init_code), foldr (appOL . toOL) nilOL bindss) where - do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) + do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl) do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding]) do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index ea10cdaf39..e2691de6c0 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -88,7 +88,7 @@ dsInnerListComp (ParStmtBlock _ stmts bndrs _) list_ty = mkListTy bndrs_tuple_type -- really use original bndrs below! - ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty + ; expr <- dsListComp (stmts ++ [noLocA $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) } @@ -479,7 +479,7 @@ dsMonadComp stmts = dsMcStmts stmts dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMcStmts [] = panic "dsMcStmts" -dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) +dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDsA loc (dsMcStmt stmt lstmts) --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr @@ -632,7 +632,7 @@ dsInnerMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op = dsMcStmts (stmts ++ - [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)]) + [noLocA (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)]) -- The `unzip` function for `GroupStmt` in a monad comprehensions diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index a007faa823..c6eb0b5fb8 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -455,7 +455,7 @@ tidy1 v _ (LazyPat _ pat) -- not fully know the zonked types yet. We sure do here. = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLoc pat) $ + putSrcSpanDs (getLocA pat) $ errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ text "Unlifted variables:") 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) @@ -514,7 +514,7 @@ tidy1 _ _ non_interesting_pat = return (idDsWrapper, non_interesting_pat) -------------------- -tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc +tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang @@ -567,7 +567,7 @@ tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc) tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p)) ------------------- -push_bang_into_newtype_arg :: SrcSpan +push_bang_into_newtype_arg :: SrcSpanAnnA -> Type -- The type of the argument we are pushing -- onto -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc @@ -584,7 +584,7 @@ push_bang_into_newtype_arg l _ty (RecCon rf) = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [] [L l (BangPat noExtField (noLoc (WildPat ty)))] + = PrefixCon [] [L l (BangPat noExtField (noLocA (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -1111,8 +1111,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 syn_exp _ _ = False --------- - tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2 - tup_arg (L _ (Missing (Scaled _ t1))) (L _ (Missing (Scaled _ t2))) = eqType t1 t2 + tup_arg (Present _ e1) (Present _ e2) = lexp e1 e2 + tup_arg (Missing (Scaled _ t1)) (Missing (Scaled _ t2)) = eqType t1 t2 tup_arg _ _ = False --------- diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot index 3014c069a5..e163a0bde2 100644 --- a/compiler/GHC/HsToCore/Match.hs-boot +++ b/compiler/GHC/HsToCore/Match.hs-boot @@ -6,7 +6,7 @@ import GHC.Tc.Utils.TcType ( Type ) import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) import GHC.Core ( CoreExpr ) import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) -import GHC.Hs.Extension ( GhcRn, GhcTc ) +import GHC.Hs.Extension ( GhcTc, GhcRn ) match :: [Id] -> Type diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 218f2ef35b..1e1744590a 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -575,7 +575,7 @@ tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc mk_con_pat con lit - = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] []) + = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] []) mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index a70538788f..a73e40cba2 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -22,7 +22,7 @@ module GHC.HsToCore.Monad ( duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, newFailLocalDs, newPredVarDs, - getSrcSpanDs, putSrcSpanDs, + getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA, mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, @@ -451,6 +451,9 @@ putSrcSpanDs (UnhelpfulSpan {}) thing_inside putSrcSpanDs (RealSrcSpan real_span _) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside +putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a +putSrcSpanDsA loc = putSrcSpanDs (locA loc) + -- | Emit a warning for the current source location -- NB: Warns whether or not -Wxyz is set warnDs :: WarnReason -> SDoc -> DsM () diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index f69600bf04..01b712a102 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -117,7 +117,7 @@ desugarPat x pat = case pat of -- Add the bang in front of the list, because it will happen before any -- nested stuff. (PmBang x pm_loc :) <$> desugarLPat x p - where pm_loc = Just (SrcInfo (L l (ppr p'))) + where pm_loc = Just (SrcInfo (L (locA l) (ppr p'))) -- (x@pat) ==> Desugar pat with x as match var and handle impedance -- mismatch with incoming match var @@ -342,7 +342,7 @@ desugarMatches vars matches = desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre) desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do pats' <- concat <$> zipWithM desugarLPat vars pats - grhss' <- desugarGRHSs match_loc (sep (map ppr pats)) grhss + grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss']) return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' } @@ -364,8 +364,8 @@ desugarLGRHS match_loc pp_pats (L _loc (GRHS _ gs _)) = do -- pp_pats is the space-separated pattern of the current Match this -- GRHS belongs to, so the @A B x@ part in @A B x | 0 <- x@. let rhs_info = case gs of - [] -> L match_loc pp_pats - (L grd_loc _):_ -> L grd_loc (pp_pats <+> vbar <+> interpp'SP gs) + [] -> L match_loc pp_pats + (L grd_loc _):_ -> L (locA grd_loc) (pp_pats <+> vbar <+> interpp'SP gs) grds <- concatMapM (desugarGuard . unLoc) gs pure PmGRHS { pg_grds = GrdVec grds, pg_rhs = SrcInfo rhs_info } @@ -385,8 +385,8 @@ desugarGuard guard = case guard of -- Deals only with simple @let@ or @where@ bindings without any polymorphism, -- recursion, pattern bindings etc. -- See Note [Long-distance information for HsLocalBinds]. -desugarLocalBinds :: LHsLocalBinds GhcTc -> DsM [PmGrd] -desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = +desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd] +desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) = concatMapM (concatMapM go . bagToList) (map snd binds) where go :: LHsBind GhcTc -> DsM [PmGrd] diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 149c683d83..e13f0ceb50 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -180,7 +180,7 @@ dsBracket wrap brack splices new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] - do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM n ; return e1 } + do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 } do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } @@ -331,15 +331,15 @@ repTopDs group@(HsGroup { hs_valds = valds } where no_splice (L loc _) - = notHandledL loc "Splices within declaration brackets" empty + = notHandledL (locA loc) "Splices within declaration brackets" empty no_default_decl (L loc decl) - = notHandledL loc "Default declarations" (ppr decl) + = notHandledL (locA loc) "Default declarations" (ppr decl) no_warn :: LWarnDecl GhcRn -> MetaM a no_warn (L loc (Warning _ thing _)) - = notHandledL loc "WARNING and DEPRECATION pragmas" $ + = notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing no_doc (L loc _) - = notHandledL loc "Haddock documentation" empty + = notHandledL (locA loc) "Haddock documentation" empty hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in quotes] @@ -466,7 +466,7 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repSynDecl tc1 bndrs rhs - ; return (Just (loc, dec)) } + ; return (Just (locA loc, dec)) } repTyClD (L loc (DataDecl { tcdLName = tc , tcdTyVars = tvs @@ -474,7 +474,7 @@ repTyClD (L loc (DataDecl { tcdLName = tc = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> repDataDefn tc1 (Left bndrs) defn - ; return (Just (loc, dec)) } + ; return (Just (locA loc, dec)) } repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = fds, @@ -491,7 +491,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds) ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 ; wrapGenSyms ss decls2 } - ; return $ Just (loc, dec) + ; return $ Just (locA loc, dec) } ------------------------- @@ -501,7 +501,7 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles)) ; roles1 <- mapM repRole roles ; roles2 <- coreList roleTyConName roles1 ; dec <- repRoleAnnotD tycon1 roles2 - ; return (loc, dec) } + ; return (locA loc, dec) } ------------------------- repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -511,7 +511,7 @@ repKiSigD (L loc kisig) = MkC th_v <- lookupLOcc v MkC th_ki <- repHsSigType ki dec <- rep2 kiSigDName [th_v, th_ki] - pure (loc, dec) + pure (locA loc, dec) ------------------------- repDataDefn :: Core TH.Name @@ -579,7 +579,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info DataFamily -> do { kind <- repFamilyResultSigToMaybeKind resultSig ; repDataFamilyD tc1 bndrs kind } - ; return (loc, dec) + ; return (locA loc, dec) } -- | Represent result signature of a type family @@ -607,7 +607,7 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> MetaM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing = coreNothing injAnnTyConName -repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) = +repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) = do { lhs' <- lookupBinder (unLoc lhs) ; rhs1 <- mapM (lookupBinder . unLoc) rhs ; rhs2 <- coreList nameTyConName rhs1 @@ -627,7 +627,7 @@ repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep]) repLFunDeps fds = repList funDepTyConName repLFunDep fds repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep) -repLFunDep (L _ (xs, ys)) +repLFunDep (L _ (FunDep _ xs ys)) = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs ys' <- repList nameTyConName (lookupBinder . unLoc) ys repFunDep xs' ys' @@ -637,13 +637,13 @@ repLFunDep (L _ (xs, ys)) repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repInstD (L loc (TyFamInstD { tfid_inst = fi_decl })) = do { dec <- repTyFamInstD fi_decl - ; return (loc, dec) } + ; return (locA loc, dec) } repInstD (L loc (DataFamInstD { dfid_inst = fi_decl })) = do { dec <- repDataFamInstD fi_decl - ; return (loc, dec) } + ; return (locA loc, dec) } repInstD (L loc (ClsInstD { cid_inst = cls_decl })) = do { dec <- repClsInstD cls_decl - ; return (loc, dec) } + ; return (locA loc, dec) } repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec)) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds @@ -682,7 +682,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat do { cxt' <- repLContext cxt ; inst_ty' <- repLTy inst_ty ; repDeriv strat' cxt' inst_ty' } - ; return (loc, dec) } + ; return (locA loc, dec) } where (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) @@ -742,7 +742,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn = checkTys tys@(HsValArg _: HsValArg _: _) = return tys checkTys _ = panic "repDataFamInstD:checkTys" -repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec)) +repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ , fd_fi = CImport (L _ cc) (L _ s) mch cis _ })) @@ -753,7 +753,7 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ cis' <- conv_cimportspec cis MkC str <- coreStringLit (static ++ chStr ++ cis') dec <- rep2 forImpDName [cc', s', str, name', typ'] - return (loc, dec) + return (locA loc, dec) where conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) @@ -786,7 +786,7 @@ repSafety PlayInterruptible = rep2_nw interruptibleName [] repSafety PlaySafe = rep2_nw safeName [] repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig +repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_fix_d loc (FixitySig _ names (Fixity _ prec dir)) @@ -825,7 +825,7 @@ repRuleD (L loc (HsRule { rd_name = n ; rhs' <- repLE rhs ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } ; wrapGenSyms ss rule } - ; return (loc, rule) } + ; return (locA loc, rule) } ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] @@ -835,10 +835,10 @@ ruleBndrNames (L _ (RuleBndrSig _ n sig)) repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) repRuleBndr (L _ (RuleBndr _ n)) - = do { MkC n' <- lookupLBinder n + = do { MkC n' <- lookupNBinder n ; rep2 ruleVarName [n'] } repRuleBndr (L _ (RuleBndrSig _ n sig)) - = do { MkC n' <- lookupLBinder n + = do { MkC n' <- lookupNBinder n ; MkC ty' <- repLTy (hsPatSigType sig) ; rep2 typedRuleVarName [n', ty'] } @@ -847,9 +847,9 @@ repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' - ; return (loc, dec) } + ; return (locA loc, dec) } -repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget) +repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget) repAnnProv (ValueAnnProvenance n) = do { -- An ANN references an identifier bound elsewhere in the module, so -- we must look it up using lookupLOcc (#19377). @@ -868,13 +868,13 @@ repAnnProv ModuleAnnProvenance repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con)) repC (L _ (ConDeclH98 { con_name = con - , con_forall = (L _ False) + , con_forall = False , con_mb_cxt = Nothing , con_args = args })) = repH98DataCon con args repC (L _ (ConDeclH98 { con_name = con - , con_forall = L _ is_existential + , con_forall = is_existential , con_ex_tvs = con_tvs , con_mb_cxt = mcxt , con_args = args })) @@ -940,7 +940,7 @@ repBangTy ty = do ------------------------------------------------------- repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause]) -repDerivs (L _ clauses) +repDerivs clauses = repListM derivClauseTyConName repDerivClause clauses repDerivClause :: LHsDerivingClause GhcRn @@ -986,22 +986,22 @@ rep_sigs = concatMapM rep_sig rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_sig (L loc (TypeSig _ nms ty)) - = mapM (rep_wc_ty_sig sigDName loc ty) nms + = mapM (rep_wc_ty_sig sigDName (locA loc) ty) nms rep_sig (L loc (PatSynSig _ nms ty)) - = mapM (rep_patsyn_ty_sig loc ty) nms + = mapM (rep_patsyn_ty_sig (locA loc) ty) nms rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) - | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms - | otherwise = mapM (rep_ty_sig sigDName loc ty) nms + | is_deflt = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms + | otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) -rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d loc fix_sig -rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig +rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) rep_sig (L loc (SpecSig _ nm tys ispec)) - = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc + = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys +rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty (locA loc) rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _ _st cls mty)) - = rep_complete_sig cls mty loc + = rep_complete_sig cls mty (locA loc) -- Desugar the explicit type variable binders in an 'LHsSigType', making -- sure not to gensym them. @@ -1028,7 +1028,7 @@ rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) = -- deliberately avoids gensymming the type variables. -- See Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes] -rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> LocatedN Name -> MetaM (SrcSpan, Core (M TH.Dec)) rep_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm @@ -1051,7 +1051,7 @@ rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) then return th_tau else repTForall th_explicit_tvs th_ctxt th_tau } -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> LocatedN Name -> MetaM (SrcSpan, Core (M TH.Dec)) -- represents a pattern synonym type signature; -- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs" @@ -1073,12 +1073,12 @@ rep_patsyn_ty_sig loc sig_ty nm ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> LocatedN Name -> MetaM (SrcSpan, Core (M TH.Dec)) rep_wc_ty_sig mk_sig loc sig_ty nm = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm -rep_inline :: Located Name +rep_inline :: LocatedN Name -> InlinePragma -- Never defaultInlinePragma -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] @@ -1091,7 +1091,7 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma +rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_specialise nm ty ispec loc @@ -1132,8 +1132,8 @@ repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i ; dataCon' fromPhaseDataConName [arg] } repPhases _ = dataCon allPhasesDataConName -rep_complete_sig :: Located [Located Name] - -> Maybe (Located Name) +rep_complete_sig :: Located [LocatedN Name] + -> Maybe (LocatedN Name) -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_complete_sig (L _ cls) mty loc @@ -1328,7 +1328,7 @@ repLTy ty = repTy (unLoc ty) -- handled separately in repTy. repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) repForallT ty - | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty) + | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty) = addHsTyVarBinds tvs $ \bndrs -> do { ctxt1 <- repLContext ctxt ; tau1 <- repLTy tau @@ -1473,7 +1473,7 @@ repLEs es = repListM expTyConName repLE es -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp)) -repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e) +repLE (L loc e) = mapReaderT (putSrcSpanDs (locA loc)) (repE e) repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp)) repE (HsVar _ (L _ x)) = @@ -1488,7 +1488,7 @@ repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar repE (HsOverLabel _ s) = repOverLabel s repE e@(HsRecFld _ f) = case f of - Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) + Unambiguous x _ -> repE (HsVar noExtField (noLocA x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) -- Remember, we're desugaring renamer output here, so @@ -1531,7 +1531,7 @@ repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs +repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyms ss z } @@ -1559,8 +1559,8 @@ repE e@(HsDo _ ctxt (L _ sts)) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = - let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) - tupArgToCoreExp (L _ a) + let tupArgToCoreExp :: HsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) + tupArgToCoreExp a | (Present _ e) <- a = do { e' <- repLE e ; coreJustM expTyConName e' } | otherwise = coreNothingM expTyConName @@ -1659,7 +1659,7 @@ the choice in HsExpanded, but it seems simpler to consult the flag (again). repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) repMatchTup (L _ (Match { m_pats = [p] - , m_grhss = GRHSs _ guards (L _ wheres) })) = + , m_grhss = GRHSs _ guards wheres })) = do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -1672,7 +1672,7 @@ repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) repClauseTup (L _ (Match { m_pats = ps - , m_grhss = GRHSs _ guards (L _ wheres) })) = + , m_grhss = GRHSs _ guards wheres })) = do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -1762,7 +1762,7 @@ repSts (BindStmt _ p e : ss) = ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} -repSts (LetStmt _ (L _ bs) : ss) = +repSts (LetStmt _ bs : ss) = do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) @@ -1791,11 +1791,11 @@ repSts [LastStmt _ e _ _] ; z <- repNoBindSt e2 ; return ([], [z]) } repSts (stmt@RecStmt{} : ss) - = do { let binders = collectLStmtsBinders CollNoDictBinders (recS_stmts stmt) + = do { let binders = collectLStmtsBinders CollNoDictBinders (unLoc $ recS_stmts stmt) ; ss1 <- mkGenSyms binders -- Bring all of binders in the recursive group into scope for the -- whole group. - ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt)) + ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt)) ; MASSERT(sort ss1 == sort ss1_other) ; z <- repRecSt (nonEmptyCoreList rss) ; (ss2,zs) <- addBinds ss1 (repSts ss) @@ -1841,7 +1841,7 @@ rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs))) panic "rep_implicit_param_bind: post typechecking" ; rhs' <- repE rhs ; ipb <- repImplicitParamBind name rhs' - ; return (loc, ipb) } + ; return (locA loc, ipb) } rep_implicit_param_name :: HsIPName -> MetaM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) @@ -1869,31 +1869,31 @@ rep_bind (L loc (FunBind fun_matches = MG { mg_alts = (L _ [L _ (Match { m_pats = [] - , m_grhss = GRHSs _ guards (L _ wheres) } + , m_grhss = GRHSs _ guards wheres } )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) - ; fn' <- lookupLBinder fn + ; fn' <- lookupNBinder fn ; p <- repPvar fn' ; ans <- repVal p guardcore wherecore ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } + ; return (locA loc, ans') } rep_bind (L loc (FunBind { fun_id = fn , fun_matches = MG { mg_alts = L _ ms } })) = do { ms1 <- mapM repClauseTup ms - ; fn' <- lookupLBinder fn + ; fn' <- lookupNBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) - ; return (loc, ans) } + ; return (locA loc, ans) } rep_bind (L loc (PatBind { pat_lhs = pat - , pat_rhs = GRHSs _ guards (L _ wheres) })) + , pat_rhs = GRHSs _ guards wheres })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } + ; return (locA loc, ans') } rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v @@ -1909,7 +1909,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn , psb_args = args , psb_def = pat , psb_dir = dir }))) - = do { syn' <- lookupLBinder syn + = do { syn' <- lookupNBinder syn ; dir' <- repPatSynDir dir ; ss <- mkGenArgSyms args ; patSynD' <- addBinds ss ( @@ -1917,7 +1917,7 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn ; pat' <- repLP pat ; repPatSynD syn' args' dir' pat' }) ; patSynD'' <- wrapGenArgSyms args ss patSynD' - ; return (loc, patSynD'') } + ; return (locA loc, patSynD'') } where mkGenArgSyms :: HsPatSynDetails GhcRn -> MetaM [GenSymBind] -- for Record Pattern Synonyms we want to conflate the selector @@ -2012,7 +2012,7 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) repLambda (L _ (Match { m_pats = ps , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] - (L _ (EmptyLocalBinds _)) } )) + (EmptyLocalBinds _) } )) = do { let bndrs = collectPatsBinders CollNoDictBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -2042,7 +2042,7 @@ repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p +repP (AsPat _ x p) = do { x' <- lookupNBinder x; p1 <- repLP p ; repPaspat x' p1 } repP (ParPat _ p) = repLP p repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } @@ -2124,8 +2124,8 @@ addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) -- Look up a locally bound name -- -lookupLBinder :: Located Name -> MetaM (Core TH.Name) -lookupLBinder n = lookupBinder (unLoc n) +lookupNBinder :: LocatedN Name -> MetaM (Core TH.Name) +lookupNBinder n = lookupBinder (unLoc n) lookupBinder :: Name -> MetaM (Core TH.Name) lookupBinder = lookupOcc @@ -2139,7 +2139,7 @@ lookupBinder = lookupOcc -- * If it is a global name, generate the "original name" representation (ie, -- the <module>:<name> form) for the associated entity -- -lookupLOcc :: Located Name -> MetaM (Core TH.Name) +lookupLOcc :: GenLocated l Name -> MetaM (Core TH.Name) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist lookupLOcc n = lookupOcc (unLoc n) @@ -2530,14 +2530,14 @@ repDerivStrategy mds thing_inside = Nothing -> thing_inside =<< nothing Just ds -> case unLoc ds of - StockStrategy -> thing_inside =<< just =<< repStockStrategy - AnyclassStrategy -> thing_inside =<< just =<< repAnyclassStrategy - NewtypeStrategy -> thing_inside =<< just =<< repNewtypeStrategy - ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $ - do ty' <- rep_ty_sig' ty - via_strat <- repViaStrategy ty' - m_via_strat <- just via_strat - thing_inside m_via_strat + StockStrategy _ -> thing_inside =<< just =<< repStockStrategy + AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy + NewtypeStrategy _ -> thing_inside =<< just =<< repNewtypeStrategy + ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $ + do ty' <- rep_ty_sig' ty + via_strat <- repViaStrategy ty' + m_via_strat <- just via_strat + thing_inside m_via_strat where nothing = coreNothingM derivStrategyTyConName just = coreJustM derivStrategyTyConName @@ -2658,7 +2658,7 @@ repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) repCtxt (MkC tys) = rep2 cxtName [tys] -repH98DataCon :: Located Name +repH98DataCon :: LocatedN Name -> HsConDeclH98Details GhcRn -> MetaM (Core (M TH.Con)) repH98DataCon con details @@ -2675,7 +2675,7 @@ repH98DataCon con details arg_vtys <- repRecConArgs ips rep2 recCName [unC con', unC arg_vtys] -repGadtDataCons :: [Located Name] +repGadtDataCons :: [LocatedN Name] -> HsConDeclGADTDetails GhcRn -> LHsType GhcRn -> MetaM (Core (M TH.Con)) @@ -2698,7 +2698,7 @@ repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)] repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps) -- Desugar the arguments in a data constructor declared with record syntax. -repRecConArgs :: Located [LConDeclField GhcRn] +repRecConArgs :: LocatedL [LConDeclField GhcRn] -> MetaM (Core [M TH.VarBangType]) repRecConArgs ips = do args <- concatMapM rep_ip (unLoc ips) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index fbee6b4120..8d0eb816c8 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -820,7 +820,7 @@ is_triv_pat _ = False ********************************************************************* -} mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc -mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed +mkLHsPatTup [] = noLocA $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats = L (getLoc (head lpats)) $ mkVanillaTuplePat lpats Boxed @@ -834,7 +834,7 @@ mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids) mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc -mkBigLHsTupId = mkChunkified mkLHsTupleExpr +mkBigLHsTupId = mkChunkified (\e -> mkLHsTupleExpr e noExtField) -- The Big equivalents for the source tuple patterns mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc @@ -980,9 +980,10 @@ dsHandleMonadicFailure ctx pat match m_fail_op = fail_expr <- dsSyntaxExpr fail_op [fail_msg] body fail_expr -mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> Located e -> String +mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> LocatedA e -> String mk_fail_msg dflags ctx pat - = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx <+> text "at" <+> ppr (getLoc pat) + = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx + <+> text "at" <+> ppr (getLocA pat) {- ********************************************************************* * * diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 4c75399ee0..6f894dfc1a 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -30,7 +31,7 @@ import GHC.Types.Avail ( Avails ) import GHC.Data.Bag ( Bag, bagToList ) import GHC.Types.Basic import GHC.Data.BooleanFormula -import GHC.Core.Class ( FunDep, className, classSCSelIds ) +import GHC.Core.Class ( className, classSCSelIds ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) ) import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) @@ -348,10 +349,12 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = modulify (HiePath file) xs' = do - top_ev_asts <- + top_ev_asts :: [HieAST Type] <- do + let + l :: SrcSpanAnnA + l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) toHie $ EvBindContext ModuleScope Nothing - $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing) - $ EvBinds ev_bs + $ L l (EvBinds ev_bs) (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file @@ -390,12 +393,17 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = , toHie $ hs_ruleds grp ] +getRealSpanA :: SrcSpanAnn' ann -> Maybe Span +getRealSpanA la = getRealSpan (locA la) + getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: GRHSs (GhcPass p) body -> SrcSpan -grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan + , Data (HsLocalBinds (GhcPass p))) + => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLoc xs) bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure [] @@ -468,13 +476,13 @@ data TVScoped a = TVS TyVarScope Scope a -- TyVarScope -- things to its right, ala RScoped -- | Each element scopes over the elements to the right -listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes :: Scope -> [LocatedA a] -> [RScoped (LocatedA a)] listScopes _ [] = [] listScopes rhsScope [pat] = [RS rhsScope pat] listScopes rhsScope (pat : pats) = RS sc pat : pats' where pats'@((RS scope p):_) = listScopes rhsScope pats - sc = combineScopes scope $ mkScope $ getLoc p + sc = combineScopes scope $ mkScope $ getLocA p -- | 'listScopes' specialised to 'PScoped' things patScopes @@ -536,11 +544,17 @@ instance HasLoc thing => HasLoc (PScoped thing) where instance HasLoc (Located a) where loc (L l _) = l +instance HasLoc (LocatedA a) where + loc (L la _) = locA la + +instance HasLoc (LocatedN a) where + loc (L la _) = locA la + instance HasLoc a => HasLoc [a] where loc [] = noSrcSpan loc xs = foldl1' combineSrcSpans $ map loc xs -instance HasLoc a => HasLoc (FamEqn (GhcPass s) a) where +instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of HsOuterImplicit{} -> foldl1' combineSrcSpans [loc a, loc b, loc c] @@ -587,6 +601,12 @@ instance ToHie (IEContext (Located ModuleName)) where idents = M.singleton (Left mname) details toHie _ = pure [] +instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where + toHie (C c (L l a)) = toHie (C c (L (locA l) a)) + +instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where + toHie (C c (L l a)) = toHie (C c (L (locA l) a)) + instance ToHie (Context (Located Var)) where toHie c = case c of C context (L (RealSrcSpan span _) name') @@ -645,7 +665,7 @@ evVarsOfTermList (EvTypeable _ ev) = EvTypeableTyLit e -> evVarsOfTermList e evVarsOfTermList (EvFun{}) = [] -instance ToHie (EvBindContext (Located TcEvBinds)) where +instance ToHie (EvBindContext (LocatedA TcEvBinds)) where toHie (EvBindContext sc sp (L span (EvBinds bs))) = concatMapM go $ bagToList bs where @@ -653,40 +673,40 @@ instance ToHie (EvBindContext (Located TcEvBinds)) where let evDeps = evVarsOfTermList $ eb_rhs evbind depNames = EvBindDeps $ map varName evDeps concatM $ - [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) + [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScopeA span)) sp) (L span $ eb_lhs evbind)) , toHie $ map (C EvidenceVarUse . L span) $ evDeps ] toHie _ = pure [] -instance ToHie (Located HsWrapper) where +instance ToHie (LocatedA HsWrapper) where toHie (L osp wrap) = case wrap of - (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs) + (WpLet bs) -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs) (WpCompose a b) -> concatM $ [toHie (L osp a), toHie (L osp b)] (WpFun a b _ _) -> concatM $ [toHie (L osp a), toHie (L osp b)] (WpEvLam a) -> - toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp)) + toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp)) $ L osp a (WpEvApp a) -> concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a _ -> pure [] -instance HiePass p => HasType (Located (HsBind (GhcPass p))) where +instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where getTypeNode (L spn bind) = case hiePass @p of - HieRn -> makeNode bind spn + HieRn -> makeNode bind (locA spn) HieTc -> case bind of - FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) - _ -> makeNode bind spn + FunBind{fun_id = name} -> makeTypeNode bind (locA spn) (varType $ unLoc name) + _ -> makeNode bind (locA spn) -instance HiePass p => HasType (Located (Pat (GhcPass p))) where +instance HiePass p => HasType (LocatedA (Pat (GhcPass p))) where getTypeNode (L spn pat) = case hiePass @p of - HieRn -> makeNode pat spn - HieTc -> makeTypeNode pat spn (hsPatType pat) + HieRn -> makeNodeA pat spn + HieTc -> makeTypeNodeA pat spn (hsPatType pat) -- | This instance tries to construct 'HieAST' nodes which include the type of -- the expression. It is not yet possible to do this efficiently for all @@ -703,10 +723,10 @@ instance HiePass p => HasType (Located (Pat (GhcPass p))) where -- expression's type is going to be expensive. -- -- See #16233 -instance HiePass p => HasType (Located (HsExpr (GhcPass p))) where +instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where getTypeNode e@(L spn e') = case hiePass @p of - HieRn -> makeNode e' spn + HieRn -> makeNodeA e' spn HieTc -> -- Some expression forms have their type immediately available let tyOpt = case e' of @@ -729,15 +749,15 @@ instance HiePass p => HasType (Located (HsExpr (GhcPass p))) where in case tyOpt of - Just t -> makeTypeNode e' spn t + Just t -> makeTypeNodeA e' spn t Nothing | skipDesugaring e' -> fallback | otherwise -> do hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w) (_,mbe) <- liftIO $ deSugarExpr hs_env e - maybe fallback (makeTypeNode e' spn . exprType) mbe + maybe fallback (makeTypeNodeA e' spn . exprType) mbe where - fallback = makeNode e' spn + fallback = makeNodeA e' spn matchGroupType :: MatchGroupTc -> Type matchGroupType (MatchGroupTc args res) = mkVisFunTys args res @@ -764,12 +784,16 @@ data HiePassEv p where class ( IsPass p , HiePass (NoGhcTcPass p) , ModifyState (IdGhcP p) - , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p)))) + , Data (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) + , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) + , Data (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) + , Data (Stmt (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) + , Data (Stmt (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) , Data (HsExpr (GhcPass p)) - , Data (HsCmd (GhcPass p)) + , Data (HsCmd (GhcPass p)) , Data (AmbiguousFieldOcc (GhcPass p)) , Data (HsCmdTop (GhcPass p)) - , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p)))) + , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) , Data (HsSplice (GhcPass p)) , Data (HsLocalBinds (GhcPass p)) , Data (FieldOcc (GhcPass p)) @@ -780,6 +804,7 @@ class ( IsPass p , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) + , Anno (IdGhcP p) ~ SrcSpanAnnN ) => HiePass p where hiePass :: HiePassEv p @@ -792,18 +817,35 @@ instance HiePass 'Typechecked where instance ToHie (Context (Located NoExtField)) where toHie _ = pure [] -instance HiePass p => ToHie (BindContext (Located (HsBind (GhcPass p)))) where +type AnnoBody p body + = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA + , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + ~ SrcSpanAnnL + , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpan + , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA + + , Data (body (GhcPass p)) + , Data (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + , Data (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + , Data (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))) + + , IsPass p + ) + +instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where toHie (BC context scope b@(L span bind)) = concatM $ getTypeNode b : case bind of FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> - [ toHie $ C (ValBind context scope $ getRealSpan span) name + [ toHie $ C (ValBind context scope $ getRealSpanA span) name , toHie matches , case hiePass @p of HieTc -> toHie $ L span wrap _ -> pure [] ] PatBind{pat_lhs = lhs, pat_rhs = rhs} -> - [ toHie $ PS (getRealSpan span) scope NoScope lhs + [ toHie $ PS (getRealSpan (locA span)) scope NoScope lhs , toHie rhs ] VarBind{var_rhs = expr} -> @@ -816,26 +858,26 @@ instance HiePass p => ToHie (BindContext (Located (HsBind (GhcPass p)))) where (toHie $ fmap (BC context scope) binds) , toHie $ map (L span . abe_wrap) xs , toHie $ - map (EvBindContext (mkScope span) (getRealSpan span) + map (EvBindContext (mkScopeA span) (getRealSpanA span) . L span) ev_binds , toHie $ map (C (EvidenceVarBind EvSigBind - (mkScope span) - (getRealSpan span)) + (mkScopeA span) + (getRealSpanA span)) . L span) ev_vars ] PatSynBind _ psb -> - [ toHie $ L span psb -- PatSynBinds only occur at the top level + [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level ] instance ( HiePass p - , ToHie (Located body) - , Data body - ) => ToHie (MatchGroup (GhcPass p) (Located body)) where + , AnnoBody p body + , ToHie (LocatedA (body (GhcPass p))) + ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where toHie mg = case mg of MG{ mg_alts = (L span alts) , mg_origin = origin} -> local (setOrigin origin) $ concatM - [ locOnly span + [ locOnly (locA span) , toHie alts ] @@ -853,14 +895,14 @@ instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where ] where lhsScope = combineScopes varScope detScope - varScope = mkLScope var - patScope = mkScope $ getLoc pat + varScope = mkLScopeN var + patScope = mkScopeA $ getLoc pat detScope = case dets of - (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScope args - (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScopeN args + (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b) (RecCon r) -> foldr go NoScope r go (RecordPatSynField a b) c = combineScopes c - $ combineScopes (mkLScope (rdrNameFieldOcc a)) (mkLScope b) + $ combineScopes (mkLScopeN (rdrNameFieldOcc a)) (mkLScopeN b) detSpan = case detScope of LocalScope a -> Just a _ -> Nothing @@ -874,9 +916,10 @@ instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where _ -> pure [] instance ( HiePass p - , Data body - , ToHie (Located body) - ) => ToHie (Located (Match (GhcPass p) (Located body))) where + , Data (body (GhcPass p)) + , AnnoBody p body + , ToHie (LocatedA (body (GhcPass p))) + ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where toHie (L span m ) = concatM $ node : case m of Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> [ toHie mctx @@ -886,8 +929,8 @@ instance ( HiePass p ] where node = case hiePass @p of - HieTc -> makeNode m span - HieRn -> makeNode m span + HieTc -> makeNodeA m span + HieRn -> makeNodeA m span instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name @@ -900,7 +943,7 @@ instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where toHie (TransStmtCtxt a) = toHie a toHie _ = pure [] -instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where +instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where toHie (PS rsp scope pscope lpat@(L ospan opat)) = concatM $ getTypeNode lpat : case opat of WildPat _ -> @@ -913,7 +956,7 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where ] AsPat _ lname pat -> [ toHie $ C (PatternBind scope - (combineScopes (mkLScope pat) pscope) + (combineScopes (mkLScopeA pat) pscope) rsp) lname , toHie $ PS rsp scope pscope pat @@ -941,7 +984,7 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where , let ev_binds = cpt_binds ext ev_vars = cpt_dicts ext wrap = cpt_wrap ext - evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope + evscope = mkScopeA ospan `combineScopes` scope `combineScopes` pscope in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds , toHie $ L ospan wrap , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) @@ -970,7 +1013,7 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where [ toHie $ PS rsp scope pscope pat , case hiePass @p of HieTc -> - let cscope = mkLScope pat in + let cscope = mkLScopeA pat in toHie $ TS (ResolvedScopes [cscope, scope, pscope]) sig HieRn -> pure [] @@ -989,48 +1032,50 @@ instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a) -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args) - where argscope = foldr combineScopes NoScope $ map mkLScope args + where argscope = foldr combineScopes NoScope $ map mkLScopeA args contextify (InfixCon a b) = InfixCon a' b' where [a', b'] = patScopes rsp scope pscope [a,b] contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a where - go (RS fscope (L spn (HsRecField lbl pat pun))) = - L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + go :: RScoped (LocatedA (HsRecField' id a1)) + -> LocatedA (HsRecField' id (PScoped a1)) -- AZ + go (RS fscope (L spn (HsRecField x lbl pat pun))) = + L spn $ HsRecField x lbl (PS rsp scope fscope pat) pun scoped_fds = listScopes pscope fds instance ToHie (TScoped (HsPatSigType GhcRn)) where toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) + [ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs++tvs) , toHie body ] -- See Note [Scoping Rules for SigPat] -instance ( ToHie (Located body) +instance ( ToHie (LocatedA (body (GhcPass p))) , HiePass p - , Data body - ) => ToHie (GRHSs (GhcPass p) (Located body)) where + , AnnoBody p body + ) => ToHie (GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))) where toHie grhs = concatM $ case grhs of GRHSs _ grhss binds -> [ toHie grhss , toHie $ RS (mkScope $ grhss_span grhs) binds ] -instance ( ToHie (Located body) - , HiePass a - , Data body - ) => ToHie (Located (GRHS (GhcPass a) (Located body))) where +instance ( ToHie (LocatedA (body (GhcPass p))) + , HiePass p + , AnnoBody p body + ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where toHie (L span g) = concatM $ node : case g of GRHS _ guards body -> - [ toHie $ listScopes (mkLScope body) guards + [ toHie $ listScopes (mkLScopeA body) guards , toHie body ] where - node = case hiePass @a of + node = case hiePass @p of HieRn -> makeNode g span HieTc -> makeNode g span -instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where +instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of HsVar _ (L _ var) -> [ toHie $ C Use (L mspan var) @@ -1041,7 +1086,7 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where [ toHie $ C Use $ L mspan $ conLikeName con ] HsRecFld _ fld -> - [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + [ toHie $ RFC RecFieldOcc Nothing (L (locA mspan) fld) ] HsOverLabel {} -> [] HsIPVar _ _ -> [] @@ -1099,11 +1144,11 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where [ toHie grhss ] HsLet _ binds expr -> - [ toHie $ RS (mkLScope expr) binds + [ toHie $ RS (mkLScopeA expr) binds , toHie expr ] HsDo _ _ (L ispan stmts) -> - [ locOnly ispan + [ locOnly (locA ispan) , toHie $ listScopes NoScope stmts ] ExplicitList _ exprs -> @@ -1114,7 +1159,7 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where , toHie $ RC RecFieldAssign $ binds ] where - con_name :: Located Name + con_name :: LocatedN Name con_name = case hiePass @p of -- Like ConPat HieRn -> con HieTc -> fmap conLikeName con @@ -1127,7 +1172,7 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where ] ExprWithTySig _ expr sig -> [ toHie expr - , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + , toHie $ TS (ResolvedScopes [mkLScopeA expr]) sig ] ArithSeq _ _ info -> [ toHie info @@ -1176,23 +1221,24 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where ] | otherwise -> [] -instance HiePass p => ToHie (Located (HsTupArg (GhcPass p))) where - toHie (L span arg) = concatM $ makeNode arg span : case arg of +-- NOTE: no longer have the location +instance HiePass p => ToHie (HsTupArg (GhcPass p)) where + toHie arg = concatM $ case arg of Present _ expr -> [ toHie expr ] Missing _ -> [] -instance ( ToHie (Located body) - , Data body +instance ( ToHie (LocatedA (body (GhcPass p))) + , AnnoBody p body , HiePass p - ) => ToHie (RScoped (Located (Stmt (GhcPass p) (Located body)))) where + ) => ToHie (RScoped (LocatedA (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))))) where toHie (RS scope (L span stmt)) = concatM $ node : case stmt of LastStmt _ body _ _ -> [ toHie body ] BindStmt _ pat body -> - [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + [ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat , toHie body ] ApplicativeStmt _ stmts _ -> @@ -1214,34 +1260,60 @@ instance ( ToHie (Located body) , toHie using , toHie by ] - RecStmt {recS_stmts = stmts} -> - [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + RecStmt {recS_stmts = L _ stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts ] where node = case hiePass @p of - HieTc -> makeNode stmt span - HieRn -> makeNode stmt span + HieTc -> makeNodeA stmt span + HieRn -> makeNodeA stmt span -instance HiePass p => ToHie (RScoped (Located (HsLocalBinds (GhcPass p)))) where - toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of +instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where + toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of EmptyLocalBinds _ -> [] HsIPBinds _ ipbinds -> case ipbinds of - IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in - [ case hiePass @p of - HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds + IPBinds evbinds xs -> let sc = combineScopes scope $ scopeHsLocaLBinds binds + sp :: SrcSpanAnnA + sp = noAnnSrcSpan $ spanHsLocaLBinds binds in + [ + case hiePass @p of + HieTc -> toHie $ EvBindContext sc (getRealSpan $ locA sp) $ L sp evbinds HieRn -> pure [] , toHie $ map (RS sc) xs ] HsValBinds _ valBinds -> - [ toHie $ RS (combineScopes scope $ mkScope sp) + [ + toHie $ RS (combineScopes scope (scopeHsLocaLBinds binds)) valBinds ] -instance HiePass p => ToHie (RScoped (Located (IPBind (GhcPass p)))) where - toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of + +scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope +scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs)) + = foldr combineScopes NoScope (bsScope ++ sigsScope) + where + bsScope :: [Scope] + bsScope = map (mkScopeA . getLoc) $ bagToList bs + sigsScope :: [Scope] + sigsScope = map (mkScope . getLocA) sigs +scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs))) + = foldr combineScopes NoScope (bsScope ++ sigsScope) + where + bsScope :: [Scope] + bsScope = map (mkScopeA . getLoc) $ concatMap (bagToList . snd) bs + sigsScope :: [Scope] + sigsScope = map (mkScope . getLocA) sigs + +scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) + = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs) +scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope + + +instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where + toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of IPBind _ (Left _) expr -> [toHie expr] IPBind _ (Right v) expr -> - [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp)) + [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp)) $ L sp v , toHie expr ] @@ -1265,11 +1337,11 @@ instance ( ToHie arg , HasLoc arg , Data arg toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields instance ( ToHie (RFContext (Located label)) - , ToHie arg , HasLoc arg , Data arg + , ToHie arg, HasLoc arg, Data arg , Data label - ) => ToHie (RContext (LHsRecField' label arg)) where - toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of - HsRecField label expr _ -> + ) => ToHie (RContext (LocatedA (HsRecField' label arg))) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of + HsRecField _ label expr _ -> [ toHie $ RFC c (getRealSpan $ loc expr) label , toHie expr ] @@ -1328,8 +1400,8 @@ instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where [ toHie cmd ] -instance HiePass p => ToHie (Located (HsCmd (GhcPass p))) where - toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of +instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where + toHie (L span cmd) = concatM $ makeNodeA cmd span : case cmd of HsCmdArrApp _ a b _ _ -> [ toHie a , toHie b @@ -1361,11 +1433,11 @@ instance HiePass p => ToHie (Located (HsCmd (GhcPass p))) where , toHie c ] HsCmdLet _ binds cmd' -> - [ toHie $ RS (mkLScope cmd') binds + [ toHie $ RS (mkLScopeA cmd') binds , toHie cmd' ] HsCmdDo _ (L ispan stmts) -> - [ locOnly ispan + [ locOnly (locA ispan) , toHie $ listScopes NoScope stmts ] XCmd _ -> [] @@ -1382,27 +1454,27 @@ instance ToHie (TyClGroup GhcRn) where , toHie instances ] -instance ToHie (Located (TyClDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (TyClDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of FamDecl {tcdFam = fdecl} -> - [ toHie (L span fdecl) + [ toHie ((L span fdecl) :: LFamilyDecl GhcRn) ] SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> - [ toHie $ C (Decl SynDec $ getRealSpan span) name - , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + [ toHie $ C (Decl SynDec $ getRealSpanA span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLocA typ]) vars , toHie typ ] DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> - [ toHie $ C (Decl DataDec $ getRealSpan span) name + [ toHie $ C (Decl DataDec $ getRealSpanA span) name , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars , toHie defn ] where - quant_scope = mkLScope $ fromMaybe (noLoc []) $ dd_ctxt defn + quant_scope = mkLScopeA $ fromMaybe (noLocA []) $ dd_ctxt defn rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc - sig_sc = maybe NoScope mkLScope $ dd_kindSig defn - con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn - deriv_sc = mkLScope $ dd_derivs defn + sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn + deriv_sc = foldr combineScopes NoScope $ map mkLScope $ dd_derivs defn ClassDecl { tcdCtxt = context , tcdLName = name , tcdTyVars = vars @@ -1412,25 +1484,25 @@ instance ToHie (Located (TyClDecl GhcRn)) where , tcdATs = typs , tcdATDefs = deftyps } -> - [ toHie $ C (Decl ClassDec $ getRealSpan span) name + [ toHie $ C (Decl ClassDec $ getRealSpanA span) name , toHie context , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars , toHie deps - , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ map (SC $ SI ClassSig $ getRealSpanA span) sigs , toHie $ fmap (BC InstanceBind ModuleScope) meths , toHie typs - , concatMapM (locOnly . getLoc) deftyps + , concatMapM (locOnly . getLocA) deftyps , toHie deftyps ] where - context_scope = mkLScope $ fromMaybe (noLoc []) context + context_scope = mkLScopeA $ fromMaybe (noLocA []) context rhs_scope = foldl1' combineScopes $ map mkScope [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] -instance ToHie (Located (FamilyDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of - FamilyDecl _ info name vars _ sig inj -> - [ toHie $ C (Decl FamDec $ getRealSpan span) name +instance ToHie (LocatedA (FamilyDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of + FamilyDecl _ info _ name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpanA span) name , toHie $ TS (ResolvedScopes [rhsSpan]) vars , toHie info , toHie $ RS injSpan sig @@ -1443,11 +1515,11 @@ instance ToHie (Located (FamilyDecl GhcRn)) where instance ToHie (FamilyInfo GhcRn) where toHie (ClosedTypeFamily (Just eqns)) = concatM $ - [ concatMapM (locOnly . getLoc) eqns + [ concatMapM (locOnly . getLocA) eqns , toHie $ map go eqns ] where - go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib toHie _ = pure [] instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where @@ -1461,15 +1533,18 @@ instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr ] -instance ToHie (Located (FunDep (Located Name))) where - toHie (L span fd@(lhs, rhs)) = concatM $ - [ makeNode fd span +instance ToHie (LocatedA (FunDep GhcRn)) where + toHie (L span fd@(FunDep _ lhs rhs)) = concatM $ + [ makeNode fd (locA span) , toHie $ map (C Use) lhs , toHie $ map (C Use) rhs ] -instance (ToHie rhs, HasLoc rhs) - => ToHie (TScoped (FamEqn GhcRn rhs)) where + +instance ToHie (TScoped (FamEqn GhcRn (HsDataDefn GhcRn))) where + toHie (TS _ f) = toHie f + +instance ToHie (TScoped (FamEqn GhcRn (LocatedA (HsType GhcRn)))) where toHie (TS _ f) = toHie f instance (ToHie rhs, HasLoc rhs) @@ -1486,7 +1561,7 @@ instance (ToHie rhs, HasLoc rhs) instance ToHie (Located (InjectivityAnn GhcRn)) where toHie (L span ann) = concatM $ makeNode ann span : case ann of - InjectivityAnn lhs rhs -> + InjectivityAnn _ lhs rhs -> [ toHie $ C Use lhs , toHie $ map (C Use) rhs ] @@ -1512,32 +1587,32 @@ instance ToHie (Located (HsDerivingClause GhcRn)) where , toHie dct ] -instance ToHie (Located (DerivClauseTys GhcRn)) where - toHie (L span dct) = concatM $ makeNode dct span : case dct of +instance ToHie (LocatedC (DerivClauseTys GhcRn)) where + toHie (L span dct) = concatM $ makeNodeA dct span : case dct of DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ] DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] instance ToHie (Located (DerivStrategy GhcRn)) where toHie (L span strat) = concatM $ makeNode strat span : case strat of - StockStrategy -> [] - AnyclassStrategy -> [] - NewtypeStrategy -> [] + StockStrategy _ -> [] + AnyclassStrategy _ -> [] + NewtypeStrategy _ -> [] ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ] -instance ToHie (Located OverlapMode) where - toHie (L span _) = locOnly span +instance ToHie (LocatedP OverlapMode) where + toHie (L span _) = locOnly (locA span) instance ToHie a => ToHie (HsScaled GhcRn a) where toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] -instance ToHie (Located (ConDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (ConDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } -> - [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names , case outer_bndrs of HsOuterImplicit{hso_ximplicit = imp_vars} -> - bindingsOnly $ map (C $ TyVarBind (mkScope outer_bndrs_loc) resScope) + bindingsOnly $ map (C $ TyVarBind (mkScopeA outer_bndrs_loc) resScope) imp_vars HsOuterExplicit{hso_bndrs = exp_bndrs} -> toHie $ tvScopes resScope NoScope exp_bndrs @@ -1547,51 +1622,51 @@ instance ToHie (Located (ConDecl GhcRn)) where ] where rhsScope = combineScopes argsScope tyScope - ctxScope = maybe NoScope mkLScope ctx + ctxScope = maybe NoScope mkLScopeA ctx argsScope = case args of PrefixConGADT xs -> scaled_args_scope xs - RecConGADT x -> mkLScope x - tyScope = mkLScope typ + RecConGADT x -> mkLScopeA x + tyScope = mkLScopeA typ resScope = ResolvedScopes [ctxScope, rhsScope] ConDeclH98 { con_name = name, con_ex_tvs = qvars , con_mb_cxt = ctx, con_args = dets } -> - [ toHie $ C (Decl ConDec $ getRealSpan span) name + [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars , toHie ctx , toHie dets ] where rhsScope = combineScopes ctxScope argsScope - ctxScope = maybe NoScope mkLScope ctx + ctxScope = maybe NoScope mkLScopeA ctx argsScope = case dets of PrefixCon _ xs -> scaled_args_scope xs InfixCon a b -> scaled_args_scope [a, b] - RecCon x -> mkLScope x + RecCon x -> mkLScopeA x where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope - scaled_args_scope = foldr combineScopes NoScope . map (mkLScope . hsScaledThing) + scaled_args_scope = foldr combineScopes NoScope . map (mkLScopeA . hsScaledThing) -instance ToHie (Located [Located (ConDeclField GhcRn)]) where +instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where toHie (L span decls) = concatM $ - [ locOnly span + [ locOnly (locA span) , toHie decls ] -instance ToHie (TScoped (HsWildCardBndrs GhcRn (Located (HsSigType GhcRn)))) where +instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where toHie (TS sc (HsWC names a)) = concatM $ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names , toHie $ TS sc a ] where span = loc a -instance ToHie (TScoped (HsWildCardBndrs GhcRn (Located (HsType GhcRn)))) where +instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where toHie (TS sc (HsWC names a)) = concatM $ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names , toHie a ] where span = loc a -instance ToHie (Located (StandaloneKindSig GhcRn)) where - toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] +instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where + toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig] instance ToHie (StandaloneKindSig GhcRn) where toHie sig = concatM $ case sig of @@ -1600,11 +1675,11 @@ instance ToHie (StandaloneKindSig GhcRn) where , toHie $ TS (ResolvedScopes []) typ ] -instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where +instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where toHie (SC (SI styp msp) (L sp sig)) = case hiePass @p of HieTc -> pure [] - HieRn -> concatM $ makeNode sig sp : case sig of + HieRn -> concatM $ makeNodeA sig sp : case sig of TypeSig _ names typ -> [ toHie $ map (C TyDecl) names , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ @@ -1615,7 +1690,7 @@ instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where ] ClassOpSig _ _ names typ -> [ case styp of - ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpanA sp) names _ -> toHie $ map (C $ TyDecl) names , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ ] @@ -1646,21 +1721,22 @@ instance HiePass p => ToHie (SigContext (Located (Sig (GhcPass p)))) where , toHie $ fmap (C Use) typ ] -instance ToHie (TScoped (Located (HsSigType GhcRn))) where - toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNode t span : - [ toHie (TVS tsc (mkScope span) bndrs) +instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where + toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span : + [ toHie (TVS tsc (mkScopeA span) bndrs) , toHie body ] +-- Check this instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where toHie (TVS tsc sc bndrs) = case bndrs of HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs -instance ToHie (Located (HsType GhcRn)) where - toHie (L span t) = concatM $ makeNode t span : case t of +instance ToHie (LocatedA (HsType GhcRn)) where + toHie (L span t) = concatM $ makeNode t (locA span) : case t of HsForAllTy _ tele body -> - let scope = mkScope $ getLoc body in + let scope = mkScope $ getLocA body in [ case tele of HsForAllVis { hsf_vis_bndrs = bndrs } -> toHie $ tvScopes (ResolvedScopes []) scope bndrs @@ -1741,8 +1817,8 @@ instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where toHie (HsTypeArg _ ty) = toHie ty toHie (HsArgPar sp) = locOnly sp -instance Data flag => ToHie (TVScoped (Located (HsTyVarBndr flag GhcRn))) where - toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of +instance Data flag => ToHie (TVScoped (LocatedA (HsTyVarBndr flag GhcRn))) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of UserTyVar _ _ var -> [ toHie $ C (TyVarBind sc tsc) var ] @@ -1760,14 +1836,14 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where varLoc = loc vars bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits -instance ToHie (Located [Located (HsType GhcRn)]) where +instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where toHie (L span tys) = concatM $ - [ locOnly span + [ locOnly (locA span) , toHie tys ] -instance ToHie (Located (ConDeclField GhcRn)) where - toHie (L span field) = concatM $ makeNode field span : case field of +instance ToHie (LocatedA (ConDeclField GhcRn)) where + toHie (L span field) = concatM $ makeNode field (locA span) : case field of ConDeclField _ fields typ _ -> [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields , toHie typ @@ -1789,8 +1865,8 @@ instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where , toHie c ] -instance ToHie (Located (SpliceDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (SpliceDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of SpliceDecl _ splice _ -> [ toHie splice ] @@ -1804,8 +1880,8 @@ instance ToHie PendingRnSplice where instance ToHie PendingTcSplice where toHie _ = pure [] -instance ToHie (LBooleanFormula (Located Name)) where - toHie (L span form) = concatM $ makeNode form span : case form of +instance ToHie (LBooleanFormula (LocatedN Name)) where + toHie (L span form) = concatM $ makeNode form (locA span) : case form of Var a -> [ toHie $ C Use a ] @@ -1822,8 +1898,8 @@ instance ToHie (LBooleanFormula (Located Name)) where instance ToHie (Located HsIPName) where toHie (L span e) = makeNode e span -instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where - toHie (L span sp) = concatM $ makeNode sp span : case sp of +instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where + toHie (L span sp) = concatM $ makeNodeA sp span : case sp of HsTypedSplice _ _ _ expr -> [ toHie expr ] @@ -1843,15 +1919,15 @@ instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where GhcTc -> case x of HsSplicedT _ -> [] -instance ToHie (Located (RoleAnnotDecl GhcRn)) where - toHie (L span annot) = concatM $ makeNode annot span : case annot of +instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where + toHie (L span annot) = concatM $ makeNodeA annot span : case annot of RoleAnnotDecl _ var roles -> [ toHie $ C Use var , concatMapM (locOnly . getLoc) roles ] -instance ToHie (Located (InstDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (InstDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of ClsInstD _ d -> [ toHie $ L span d ] @@ -1862,23 +1938,23 @@ instance ToHie (Located (InstDecl GhcRn)) where [ toHie $ L span d ] -instance ToHie (Located (ClsInstDecl GhcRn)) where +instance ToHie (LocatedA (ClsInstDecl GhcRn)) where toHie (L span decl) = concatM - [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + [ toHie $ TS (ResolvedScopes [mkScopeA span]) $ cid_poly_ty decl , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl - , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl - , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ map (SC $ SI InstSig $ getRealSpanA span) $ cid_sigs decl + , concatMapM (locOnly . getLocA) $ cid_tyfam_insts decl , toHie $ cid_tyfam_insts decl - , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl + , concatMapM (locOnly . getLocA) $ cid_datafam_insts decl , toHie $ cid_datafam_insts decl , toHie $ cid_overlap_mode decl ] -instance ToHie (Located (DataFamInstDecl GhcRn)) where - toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d +instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d -instance ToHie (Located (TyFamInstDecl GhcRn)) where - toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d +instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where + toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where toHie (C c (FieldOcc n (L l _))) = case hiePass @p of @@ -1891,30 +1967,30 @@ instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) , toHie $ C Use b ] -instance ToHie (Located (DerivDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (DerivDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of DerivDecl _ typ strat overlap -> [ toHie $ TS (ResolvedScopes []) typ , toHie strat , toHie overlap ] -instance ToHie (Located (FixitySig GhcRn)) where - toHie (L span sig) = concatM $ makeNode sig span : case sig of +instance ToHie (LocatedA (FixitySig GhcRn)) where + toHie (L span sig) = concatM $ makeNodeA sig span : case sig of FixitySig _ vars _ -> [ toHie $ map (C Use) vars ] -instance ToHie (Located (DefaultDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (DefaultDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of DefaultDecl _ typs -> [ toHie typs ] -instance ToHie (Located (ForeignDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (ForeignDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> - [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpanA span) name , toHie $ TS (ResolvedScopes []) sig , toHie fi ] @@ -1937,49 +2013,49 @@ instance ToHie ForeignExport where , locOnly b ] -instance ToHie (Located (WarnDecls GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (WarnDecls GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of Warnings _ _ warnings -> [ toHie warnings ] -instance ToHie (Located (WarnDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (WarnDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of Warning _ vars _ -> [ toHie $ map (C Use) vars ] -instance ToHie (Located (AnnDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (AnnDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of HsAnnotation _ _ prov expr -> [ toHie prov , toHie expr ] -instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where +instance ToHie (AnnProvenance GhcRn) where toHie (ValueAnnProvenance a) = toHie $ C Use a toHie (TypeAnnProvenance a) = toHie $ C Use a toHie ModuleAnnProvenance = pure [] -instance ToHie (Located (RuleDecls GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (RuleDecls GhcRn)) where + toHie (L span decl) = concatM $ makeNodeA decl span : case decl of HsRules _ _ rules -> [ toHie rules ] -instance ToHie (Located (RuleDecl GhcRn)) where +instance ToHie (LocatedA (RuleDecl GhcRn)) where toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM - [ makeNode r span + [ makeNodeA r span , locOnly $ getLoc rname , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope span) bndrs + , toHie $ map (RS $ mkScope (locA span)) bndrs , toHie exprA , toHie exprB ] where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) - exprA_sc = mkLScope exprA - exprB_sc = mkLScope exprB + exprA_sc = mkLScopeA exprA + exprB_sc = mkLScopeA exprB instance ToHie (RScoped (Located (RuleBndr GhcRn))) where toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of @@ -1991,8 +2067,8 @@ instance ToHie (RScoped (Located (RuleBndr GhcRn))) where , toHie $ TS (ResolvedScopes [sc]) typ ] -instance ToHie (Located (ImportDecl GhcRn)) where - toHie (L span decl) = concatM $ makeNode decl span : case decl of +instance ToHie (LocatedA (ImportDecl GhcRn)) where + toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> [ toHie $ IEC Import name , toHie $ fmap (IEC ImportAs) as @@ -2000,14 +2076,14 @@ instance ToHie (Located (ImportDecl GhcRn)) where ] where goIE (hiding, (L sp liens)) = concatM $ - [ locOnly sp + [ locOnly (locA sp) , toHie $ map (IEC c) liens ] where c = if hiding then ImportHiding else Import -instance ToHie (IEContext (Located (IE GhcRn))) where - toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of +instance ToHie (IEContext (LocatedA (IE GhcRn))) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of IEVar _ n -> [ toHie $ IEC c n ] @@ -2030,14 +2106,14 @@ instance ToHie (IEContext (Located (IE GhcRn))) where IEDocNamed _ _ -> [] instance ToHie (IEContext (LIEWrappedName Name)) where - toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of IEName n -> [ toHie $ C (IEThing c) n ] - IEPattern p -> + IEPattern _ p -> [ toHie $ C (IEThing c) p ] - IEType n -> + IEType _ n -> [ toHie $ C (IEThing c) n ] diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index c4c86dd216..0a9150f532 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -25,6 +25,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Types.Var import GHC.Types.Var.Env +import GHC.Parser.Annotation import GHC.Iface.Ext.Types @@ -523,6 +524,9 @@ locOnly (RealSrcSpan span _) = do pure [Node e span []] locOnly _ = pure [] +mkScopeA :: SrcSpanAnn' ann -> Scope +mkScopeA l = mkScope (locA l) + mkScope :: SrcSpan -> Scope mkScope (RealSrcSpan sp _) = LocalScope sp mkScope _ = NoScope @@ -530,6 +534,12 @@ mkScope _ = NoScope mkLScope :: Located a -> Scope mkLScope = mkScope . getLoc +mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope +mkLScopeA = mkScope . locA . getLoc + +mkLScopeN :: LocatedN a -> Scope +mkLScopeN = mkScope . getLocA + combineScopes :: Scope -> Scope -> Scope combineScopes ModuleScope _ = ModuleScope combineScopes _ ModuleScope = ModuleScope @@ -541,6 +551,14 @@ combineScopes (LocalScope a) (LocalScope b) = mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni +{-# INLINEABLE makeNodeA #-} +makeNodeA + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpanAnn' ann -- ^ return an empty list if this is unhelpful + -> ReaderT NodeOrigin m [HieAST b] +makeNodeA x spn = makeNode x (locA spn) + {-# INLINEABLE makeNode #-} makeNode :: (Monad m, Data a) @@ -556,6 +574,15 @@ makeNode x spn = do cons = mkFastString . show . toConstr $ x typ = mkFastString . show . typeRepTyCon . typeOf $ x +{-# INLINEABLE makeTypeNodeA #-} +makeTypeNodeA + :: (Monad m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpanAnnA -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> ReaderT NodeOrigin m [HieAST Type] +makeTypeNodeA x spn etyp = makeTypeNode x (locA spn) etyp + {-# INLINEABLE makeTypeNode #-} makeTypeNode :: (Monad m, Data a) diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 76079ae8ff..26694c1db4 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -106,6 +106,7 @@ import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF import Control.Monad +import GHC.Parser.Annotation {- This module takes @@ -258,7 +259,7 @@ mergeIfaceDecl d1 d2 (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) in d1 { ifBody = (ifBody d1) { ifSigs = ops, - ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2] + ifMinDef = BF.mkOr [noLocA bf1, noLocA bf2] } } `withRolesFrom` d2 -- It doesn't matter; we'll check for consistency later when diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index c17444ddcb..f786940591 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -62,6 +62,8 @@ import GHC.Data.Maybe ( orElse ) import GHC.Utils.Outputable import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) +import GHC.Utils.Panic +import GHC.Prelude import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString) @@ -85,6 +87,8 @@ import GHC.Parser.Errors import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR) + +import qualified Data.Semigroup as Semi } %expect 0 -- shift/reduce conflicts @@ -497,7 +501,7 @@ Ambiguity: {- Note [Parser API Annotations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A lot of the productions are now cluttered with calls to -aa,am,ams,amms etc. +aa,am,acs,acsA etc. These are helper functions to make sure that the locations of the various keywords such as do / let / in are captured for use by tools @@ -511,10 +515,6 @@ See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations for some background. -If you modify the parser and want to ensure that the API annotations are processed -correctly, see the README in (REPO)/utils/check-api-annotations for details on -how to set up a test using the check-api-annotations utility, and interpret the -output it generates. -} {- Note [Parsing lists] @@ -747,15 +747,15 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } ----------------------------------------------------------------------------- -- Identifiers; one of the entry points -identifier :: { Located RdrName } +identifier :: { LocatedN RdrName } : qvar { $1 } | qcon { $1 } | qvarop { $1 } | qconop { $1 } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) - [mop $1,mu AnnRarrow $2,mcp $3] } - | '->' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) - [mu AnnRarrow $1] } + | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow (glAA $1) []) } ----------------------------------------------------------------------------- -- Backpack stuff @@ -802,7 +802,7 @@ litpkgname_segment :: { Located FastString } -- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off. -- See Note [Minus tokens] in GHC.Parser.Lexer -HYPHEN :: { [AddAnn] } +HYPHEN :: { [AddApiAnn] } : '-' { [mj AnnMinus $1 ] } | PREFIX_MINUS { [mj AnnMinus $1 ] } | VARSYM {% if (getVARSYM $1 == fsLit "-") @@ -846,12 +846,12 @@ unitdecl :: { LHsUnitDecl PackageName } NotBoot -> HsSrcFile IsBoot -> HsBootFile) $3 - (Just $ sL1 $1 (HsModule (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) } + (Just $ sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) } | 'signature' modid maybemodwarning maybeexports 'where' body { sL1 $1 $ DeclD HsigFile $2 - (Just $ sL1 $1 (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) } + (Just $ sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) } | 'module' maybe_src modid { sL1 $1 $ DeclD (case snd $2 of NotBoot -> HsSrcFile @@ -880,23 +880,23 @@ unitdecl :: { LHsUnitDecl PackageName } signature :: { Located HsModule } : 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) - (snd $ sndOf3 $6) $3 Nothing) - ) - ([mj AnnSignature $1, mj AnnWhere $5] ++ fstOf3 $6) } + acs (\cs-> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs) + (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) + (snd $ sndOf3 $6) $3 Nothing)) + ) } module :: { Located HsModule } : 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) + acsFinal (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs) + (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing) - ) - ([mj AnnModule $1, mj AnnWhere $5] ++ fstOf3 $6) } + )) } | body2 {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule (thdOf3 $1) Nothing Nothing - (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing)) - (fstOf3 $1) } + acsFinal (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs) + (thdOf3 $1) Nothing Nothing + (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))) } missing_module_keyword :: { () } : {- empty -} {% pushModuleContext } @@ -904,38 +904,39 @@ missing_module_keyword :: { () } implicit_top :: { () } : {- empty -} {% pushModuleContext } -maybemodwarning :: { Maybe (Located WarningTxt) } +maybemodwarning :: { Maybe (LocatedP WarningTxt) } : '{-# DEPRECATED' strings '#-}' - {% ajs (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2)) - (mo $1:mc $3: (fst $ unLoc $2)) } + {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) + (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) } | '{-# WARNING' strings '#-}' - {% ajs (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2)) - (mo $1:mc $3 : (fst $ unLoc $2)) } + {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (snd $ unLoc $2)) + (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))} | {- empty -} { Nothing } -body :: { ([AddAnn] +body :: { (AnnList ,([LImportDecl GhcPs], [LHsDecl GhcPs]) ,LayoutInfo) } - : '{' top '}' { (moc $1:mcc $3:(fst $2) + : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2) , snd $2, ExplicitBraces) } - | vocurly top close { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) } + | vocurly top close { (AnnList Nothing Nothing Nothing [] (fst $2) + , snd $2, VirtualBraces (getVOCURLY $1)) } -body2 :: { ([AddAnn] +body2 :: { (AnnList ,([LImportDecl GhcPs], [LHsDecl GhcPs]) ,LayoutInfo) } - : '{' top '}' { (moc $1:mcc $3 - :(fst $2), snd $2, ExplicitBraces) } - | missing_module_keyword top close { ([],snd $2, VirtualBraces leftmostColumn) } + : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2) + , snd $2, ExplicitBraces) } + | missing_module_keyword top close { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) } -top :: { ([AddAnn] +top :: { ([TrailingAnn] ,([LImportDecl GhcPs], [LHsDecl GhcPs])) } : semis top1 { ($1, $2) } top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } - : importdecls_semi topdecls_semi { (reverse $1, cvTopDecls $2) } - | importdecls_semi topdecls { (reverse $1, cvTopDecls $2) } - | importdecls { (reverse $1, []) } + : importdecls_semi topdecls_cs_semi { (reverse $1, cvTopDecls $2) } + | importdecls_semi topdecls_cs { (reverse $1, cvTopDecls $2) } + | importdecls { (reverse $1, []) } ----------------------------------------------------------------------------- -- Module declaration & imports only @@ -943,15 +944,17 @@ top1 :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) } header :: { Located HsModule } : 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing - )) [mj AnnModule $1,mj AnnWhere $5] } + acs (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs) + NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + ))) } | 'signature' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc -> - ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing - )) [mj AnnModule $1,mj AnnWhere $5] } + acs (\cs -> (L loc (HsModule (ApiAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs) + NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing + ))) } | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule NoLayoutInfo Nothing Nothing $1 [] Nothing + return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl GhcPs] } @@ -972,73 +975,80 @@ header_top_importdecls :: { [LImportDecl GhcPs] } ----------------------------------------------------------------------------- -- The Export List -maybeexports :: { (Maybe (Located [LIE GhcPs])) } - : '(' exportlist ')' {% amsL (comb2 $1 $>) ([mop $1,mcp $3] ++ (fst $2)) >> - return (Just (sLL $1 $> (fromOL $ snd $2))) } +maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) } + : '(' exportlist ')' {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2)) + (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) } | {- empty -} { Nothing } -exportlist :: { ([AddAnn], OrdList (LIE GhcPs)) } +exportlist :: { ([AddApiAnn], OrdList (LIE GhcPs)) } : exportlist1 { ([], $1) } | {- empty -} { ([], nilOL) } -- trailing comma: - | exportlist1 ',' { ([mj AnnComma $2], $1) } + | exportlist1 ',' {% case $1 of + SnocOL hs t -> do + t' <- addTrailingCommaA t (gl $2) + return ([], snocOL hs t')} | ',' { ([mj AnnComma $1], nilOL) } exportlist1 :: { OrdList (LIE GhcPs) } : exportlist1 ',' export - {% (addAnnotation (oll $1) AnnComma (gl $2) ) >> - return ($1 `appOL` $3) } + {% let ls = $1 + in if isNilOL ls + then return (ls `appOL` $3) + else case ls of + SnocOL hs t -> do + t' <- addTrailingCommaA t (gl $2) + return (snocOL hs t' `appOL` $3)} | export { $1 } -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available export :: { OrdList (LIE GhcPs) } - : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) - >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } - | 'module' modid {% amsu (sLL $1 $> (IEModuleContents noExtField $2)) - [mj AnnModule $1] } - | 'pattern' qcon {% amsu (sLL $1 $> (IEVar noExtField (sLL $1 $> (IEPattern $2)))) - [mj AnnPattern $1] } - -export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } + : qcname_ext export_subspec {% mkModuleImpExp (fst $ unLoc $2) $1 (snd $ unLoc $2) + >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc $1) $> ie)) } + | 'module' modid {% fmap (unitOL . reLocA) (acs (\cs -> sLL $1 $> (IEModuleContents (ApiAnn (glR $1) [mj AnnModule $1] cs) $2))) } + | 'pattern' qcon { unitOL (reLocA (sLL $1 (reLocN $>) + (IEVar noExtField (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2))))) } + +export_subspec :: { Located ([AddApiAnn],ImpExpSubSpec) } : {- empty -} { sL0 ([],ImpExpAbs) } | '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2)) >>= \(as,ie) -> return $ sLL $1 $> (as ++ [mop $1,mcp $3] ++ fst $2, ie) } - -qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } +qcnames :: { ([AddApiAnn], [LocatedA ImpExpQcSpec]) } : {- empty -} { ([],[]) } | qcnames1 { $1 } -qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list - : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(L _ ImpExpQcWildcard) -> - return ([mj AnnComma $2, mj AnnDotdot l] - ,(snd (unLoc $3) : snd $1)) - l -> (ams (head (snd $1)) [mj AnnComma $2] >> - return (fst $1 ++ fst (unLoc $3), - snd (unLoc $3) : snd $1)) } - +qcnames1 :: { ([AddApiAnn], [LocatedA ImpExpQcSpec]) } -- A reversed list + : qcnames1 ',' qcname_ext_w_wildcard {% case (snd $1) of + (l@(L la ImpExpQcWildcard):t) -> + do { l' <- addTrailingCommaA l (gl $2) + ; return ([mj AnnDotdot (reLoc l), + mj AnnComma $2] + ,(snd (unLoc $3) : l' : t)) } + (l:t) -> + do { l' <- addTrailingCommaA l (gl $2) + ; return (fst $1 ++ fst (unLoc $3) + , snd (unLoc $3) : l' : t)} } -- Annotations re-added in mkImpExpSubSpec | qcname_ext_w_wildcard { (fst (unLoc $1),[snd (unLoc $1)]) } -- Variable, data constructor or wildcard -- or tagged type constructor -qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) } - : qcname_ext { sL1 $1 ([],$1) } - | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) } +qcname_ext_w_wildcard :: { Located ([AddApiAnn], LocatedA ImpExpQcSpec) } + : qcname_ext { sL1A $1 ([],$1) } + | '..' { sL1 $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard) } -qcname_ext :: { Located ImpExpQcSpec } - : qcname { sL1 $1 (ImpExpQcName $1) } +qcname_ext :: { LocatedA ImpExpQcSpec } + : qcname { reLocA $ sL1N $1 (ImpExpQcName $1) } | 'type' oqtycon {% do { n <- mkTypeImpExp $2 - ; ams (sLL $1 $> (ImpExpQcType n)) - [mj AnnType $1] } } + ; return $ sLLa $1 (reLocN $>) (ImpExpQcType (glAA $1) n) }} -qcname :: { Located RdrName } -- Variable or type constructor +qcname :: { LocatedN RdrName } -- Variable or type constructor : qvar { $1 } -- Things which look like functions -- Note: This includes record selectors but -- also (-.->), see #11432 @@ -1051,13 +1061,13 @@ qcname :: { Located RdrName } -- Variable or type constructor -- top handles the fact that these may be optional. -- One or more semicolons -semis1 :: { [AddAnn] } -semis1 : semis1 ';' { mj AnnSemi $2 : $1 } - | ';' { [mj AnnSemi $1] } +semis1 :: { [TrailingAnn] } +semis1 : semis1 ';' { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) } + | ';' { msemi $1 } -- Zero or more semicolons -semis :: { [AddAnn] } -semis : semis ';' { mj AnnSemi $2 : $1 } +semis :: { [TrailingAnn] } +semis : semis ';' { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) } | {- empty -} { [] } -- No trailing semicolons, non-empty @@ -1070,7 +1080,8 @@ importdecls importdecls_semi :: { [LImportDecl GhcPs] } importdecls_semi : importdecls_semi importdecl semis1 - {% ams $2 $3 >> return ($2 : $1) } + {% do { i <- amsA $2 $3 + ; return (i : $1)} } | {- empty -} { [] } importdecl :: { LImportDecl GhcPs } @@ -1079,60 +1090,67 @@ importdecl :: { LImportDecl GhcPs } ; let { ; mPreQual = unLoc $4 ; mPostQual = unLoc $7 } ; checkImportDecl mPreQual mPostQual - ; ams (L (comb5 $1 $6 $7 (snd $8) $9) $ - ImportDecl { ideclExt = noExtField + ; let anns + = ApiAnnImportDecl + { importDeclAnnImport = glAA $1 + , importDeclAnnPragma = fst $ fst $2 + , importDeclAnnSafe = fst $3 + , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual + , importDeclAnnPackage = fst $5 + , importDeclAnnAs = fst $8 + } + ; fmap reLocA $ acs (\cs -> L (comb5 $1 $6 $7 (snd $8) $9) $ + ImportDecl { ideclExt = ApiAnn (glR $1) anns cs , ideclSourceSrc = snd $ fst $2 , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 - , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual + , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual , ideclImplicit = False , ideclAs = unLoc (snd $8) , ideclHiding = unLoc $9 }) - (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList mPreQual) - ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst $8) } } -maybe_src :: { (([AddAnn],SourceText),IsBootInterface) } - : '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1) +maybe_src :: { ((Maybe (AnnAnchor,AnnAnchor),SourceText),IsBootInterface) } + : '{-# SOURCE' '#-}' { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1) , IsBoot) } - | {- empty -} { (([],NoSourceText),NotBoot) } + | {- empty -} { ((Nothing,NoSourceText),NotBoot) } -maybe_safe :: { ([AddAnn],Bool) } - : 'safe' { ([mj AnnSafe $1],True) } - | {- empty -} { ([],False) } +maybe_safe :: { (Maybe AnnAnchor,Bool) } + : 'safe' { (Just (glAA $1),True) } + | {- empty -} { (Nothing, False) } -maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } +maybe_pkg :: { (Maybe AnnAnchor,Maybe StringLiteral) } : STRING {% do { let { pkgFS = getSTRING $1 } ; unless (looksLikePackageName (unpackFS pkgFS)) $ addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc $1) - ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } } - | {- empty -} { ([],Nothing) } + ; return (Just (glAA $1), Just (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } } + | {- empty -} { (Nothing,Nothing) } -optqualified :: { Located (Maybe (Located Token)) } - : 'qualified' { sL1 $1 (Just $1) } +optqualified :: { Located (Maybe AnnAnchor) } + : 'qualified' { sL1 $1 (Just (glAA $1)) } | {- empty -} { noLoc Nothing } -maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) } - : 'as' modid { ([mj AnnAs $1] +maybeas :: { (Maybe AnnAnchor,Located (Maybe (Located ModuleName))) } + : 'as' modid { (Just (glAA $1) ,sLL $1 $> (Just $2)) } - | {- empty -} { ([],noLoc Nothing) } + | {- empty -} { (Nothing,noLoc Nothing) } -maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) } +maybeimpspec :: { Located (Maybe (Bool, LocatedL [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } -impspec :: { Located (Bool, Located [LIE GhcPs]) } - : '(' exportlist ')' {% ams (sLL $1 $> (False, - sLL $1 $> $ fromOL (snd $2))) - ([mop $1,mcp $3] ++ (fst $2)) } - | 'hiding' '(' exportlist ')' {% ams (sLL $1 $> (True, - sLL $1 $> $ fromOL (snd $3))) - ([mj AnnHiding $1,mop $2,mcp $4] ++ (fst $3)) } +impspec :: { Located (Bool, LocatedL [LIE GhcPs]) } + : '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2) + (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) + ; return $ sLL $1 $> (False, es)} } + | 'hiding' '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3) + (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) []) + ; return $ sLL $1 $> (True, es)} } ----------------------------------------------------------------------------- -- Fixity Declarations @@ -1147,10 +1165,12 @@ infix :: { Located FixityDirection } | 'infixl' { sL1 $1 InfixL } | 'infixr' { sL1 $1 InfixR } -ops :: { Located (OrdList (Located RdrName)) } - : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))} - | op { sL1 $1 (unitOL $1) } +ops :: { Located (OrdList (LocatedN RdrName)) } + : ops ',' op {% case (unLoc $1) of + SnocOL hs t -> do + t' <- addTrailingCommaN t (gl $2) + return (sLL $1 (reLocN $>) (snocOL hs t' `appOL` unitOL $3)) } + | op { sL1N $1 (unitOL $1) } ----------------------------------------------------------------------------- -- Top-Level Declarations @@ -1161,27 +1181,39 @@ topdecls :: { OrdList (LHsDecl GhcPs) } -- May have trailing semicolons, can be empty topdecls_semi :: { OrdList (LHsDecl GhcPs) } - : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) } + : topdecls_semi topdecl semis1 {% do { t <- amsA $2 $3 + ; return ($1 `snocOL` t) }} | {- empty -} { nilOL } + +----------------------------------------------------------------------------- +-- Each topdecl accumulates prior comments +-- No trailing semicolons, non-empty +topdecls_cs :: { OrdList (LHsDecl GhcPs) } + : topdecls_cs_semi topdecl_cs { $1 `snocOL` $2 } + +-- May have trailing semicolons, can be empty +topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) } + : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsA $2 $3 + ; return ($1 `snocOL` t) }} + | {- empty -} { nilOL } +topdecl_cs :: { LHsDecl GhcPs } +topdecl_cs : topdecl {% commentsPA $1 } + +----------------------------------------------------------------------------- topdecl :: { LHsDecl GhcPs } : cl_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } | ty_decl { sL1 $1 (TyClD noExtField (unLoc $1)) } | standalone_kind_sig { sL1 $1 (KindSigD noExtField (unLoc $1)) } | inst_decl { sL1 $1 (InstD noExtField (unLoc $1)) } - | stand_alone_deriving { sLL $1 $> (DerivD noExtField (unLoc $1)) } + | stand_alone_deriving { sL1 $1 (DerivD noExtField (unLoc $1)) } | role_annot { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) } - | 'default' '(' comma_types0 ')' {% ams (sLL $1 $> (DefD noExtField (DefaultDecl noExtField $3))) - [mj AnnDefault $1 - ,mop $2,mcp $4] } - | 'foreign' fdecl {% ams (sLL $1 $> (snd $ unLoc $2)) - (mj AnnForeign $1:(fst $ unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getDEPRECATED_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | '{-# WARNING' warnings '#-}' {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getWARNING_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } - | '{-# RULES' rules '#-}' {% ams (sLL $1 $> $ RuleD noExtField (HsRules noExtField (getRULES_PRAGs $1) (fromOL $2))) - [mo $1,mc $3] } + | 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $> + (DefD noExtField (DefaultDecl (ApiAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) } + | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (ApiAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) } + | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn (glR $1) [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) } + | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (ApiAnn (glR $1) [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) } + | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (ApiAnn (glR $1) [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) } | annotation { $1 } | decl_no_th { $1 } @@ -1190,13 +1222,14 @@ topdecl :: { LHsDecl GhcPs } -- but we treat an arbitrary expression just as if -- it had a $(..) wrapped around it | infixexp {% runPV (unECP $1) >>= \ $1 -> - return $ sLL $1 $> $ mkSpliceDecl $1 } + do { d <- mkSpliceDecl $1 + ; commentsPA d }} -- Type classes -- cl_decl :: { LTyClDecl GhcPs } : 'class' tycl_hdr fds where_cls - {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4)) + {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4)) (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) } -- Type declarations (toplevel) @@ -1211,152 +1244,148 @@ ty_decl :: { LTyClDecl GhcPs } -- -- Note the use of type for the head; this allows -- infix type constructors to be declared - {% amms (mkTySynonym (comb2 $1 $4) $2 $4) - [mj AnnType $1,mj AnnEqual $3] } + {% mkTySynonym (comb2A $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] } -- type family declarations | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info where_type_family -- Note the use of type for the head; this allows -- infix type constructors to be declared - {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3 - (snd $ unLoc $4) (snd $ unLoc $5)) - (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4) - ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } + {% mkFamDecl (comb4 $1 (reLoc $3) $4 $5) (snd $ unLoc $6) TopLevel $3 + (snd $ unLoc $4) (snd $ unLoc $5) + (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4) + ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } -- ordinary data type or newtype declaration | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings - {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 Nothing (reverse (snd $ unLoc $4)) - (fmap reverse $5)) + (fmap reverse $5) + ((fst $ unLoc $1):(fst $ unLoc $4)) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty - ((fst $ unLoc $1):(fst $ unLoc $4)) } -- ordinary GADT declaration | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist maybe_derivings - {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 (snd $ unLoc $4) (snd $ unLoc $5) - (fmap reverse $6) ) + (fmap reverse $6) + ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty - ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } -- data/newtype family | 'data' 'family' type opt_datafam_kind_sig - {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3 - (snd $ unLoc $4) Nothing) - (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } + {% mkFamDecl (comb3 $1 $2 $4) DataFamily TopLevel $3 + (snd $ unLoc $4) Nothing + (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) } -- standalone kind signature standalone_kind_sig :: { LStandaloneKindSig GhcPs } : 'type' sks_vars '::' sigktype - {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4) - [mj AnnType $1,mu AnnDcolon $3] } + {% mkStandaloneKindSig (comb2A $1 $4) (L (gl $2) $ unLoc $2) $4 + [mj AnnType $1,mu AnnDcolon $3]} -- See also: sig_vars -sks_vars :: { Located [Located RdrName] } -- Returned in reverse order +sks_vars :: { Located [LocatedN RdrName] } -- Returned in reverse order : sks_vars ',' oqtycon - {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | oqtycon { sL1 $1 [$1] } + {% case unLoc $1 of + (h:t) -> do + h' <- addTrailingCommaN h (gl $2) + return (sLL $1 (reLocN $>) ($3 : h' : t)) } + | oqtycon { sL1N $1 [$1] } inst_decl :: { LInstDecl GhcPs } : 'instance' overlap_pragma inst_type where_inst {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4) - ; let cid = ClsInstDecl { cid_ext = noExtField + ; let anns = (mj AnnInstance $1 : (fst $ unLoc $4)) + ; let cid cs = ClsInstDecl + { cid_ext = (ApiAnn (glR $1) anns cs, NoAnnSortKey) , cid_poly_ty = $3, cid_binds = binds , cid_sigs = mkClassOpSigs sigs , cid_tyfam_insts = ats , cid_overlap_mode = $2 , cid_datafam_insts = adts } - ; ams (L (comb3 $1 $3 $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) - (mj AnnInstance $1 : (fst $ unLoc $4)) } } + ; acsA (\cs -> L (comb3 $1 (reLoc $3) $4) + (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs })) + } } -- type instance declarations | 'type' 'instance' ty_fam_inst_eqn - {% ams $3 (fst $ unLoc $3) - >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) - (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } + {% mkTyFamInst (comb2A $1 $3) (unLoc $3) + (mj AnnType $1:mj AnnInstance $2:[]) } -- data/newtype instance declaration | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4) + {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4) Nothing (reverse (snd $ unLoc $5)) - (fmap reverse $6)) - ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) } + (fmap reverse $6) + ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) } -- GADT instance declaration | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig gadt_constrlist maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4) + {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6) - (fmap reverse $7)) - ((fst $ unLoc $1):mj AnnInstance $2 - :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) } - -overlap_pragma :: { Maybe (Located OverlapMode) } - : '{-# OVERLAPPABLE' '#-}' {% ajs (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) - [mo $1,mc $2] } - | '{-# OVERLAPPING' '#-}' {% ajs (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) - [mo $1,mc $2] } - | '{-# OVERLAPS' '#-}' {% ajs (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) - [mo $1,mc $2] } - | '{-# INCOHERENT' '#-}' {% ajs (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) - [mo $1,mc $2] } + (fmap reverse $7) + ((fst $ unLoc $1):mj AnnInstance $2 + :(fst $ unLoc $5)++(fst $ unLoc $6)) } + +overlap_pragma :: { Maybe (LocatedP OverlapMode) } + : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) + (AnnPragma (mo $1) (mc $2) []) } + | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) + (AnnPragma (mo $1) (mc $2) []) } + | '{-# OVERLAPS' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1))) + (AnnPragma (mo $1) (mc $2) []) } + | '{-# INCOHERENT' '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1))) + (AnnPragma (mo $1) (mc $2) []) } | {- empty -} { Nothing } deriv_strategy_no_via :: { LDerivStrategy GhcPs } - : 'stock' {% ams (sL1 $1 StockStrategy) - [mj AnnStock $1] } - | 'anyclass' {% ams (sL1 $1 AnyclassStrategy) - [mj AnnAnyclass $1] } - | 'newtype' {% ams (sL1 $1 NewtypeStrategy) - [mj AnnNewtype $1] } + : 'stock' {% acs (\cs -> sL1 $1 (StockStrategy (ApiAnn (glR $1) [mj AnnStock $1] cs))) } + | 'anyclass' {% acs (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn (glR $1) [mj AnnAnyclass $1] cs))) } + | 'newtype' {% acs (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn (glR $1) [mj AnnNewtype $1] cs))) } deriv_strategy_via :: { LDerivStrategy GhcPs } - : 'via' sigktype {% ams (sLL $1 $> (ViaStrategy $2)) - [mj AnnVia $1] } + : 'via' sigktype {% acs (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (ApiAnn (glR $1) [mj AnnVia $1] cs) + $2))) } deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } - : 'stock' {% ajs (sL1 $1 StockStrategy) - [mj AnnStock $1] } - | 'anyclass' {% ajs (sL1 $1 AnyclassStrategy) - [mj AnnAnyclass $1] } - | 'newtype' {% ajs (sL1 $1 NewtypeStrategy) - [mj AnnNewtype $1] } + : 'stock' {% fmap Just $ acs (\cs -> sL1 $1 (StockStrategy (ApiAnn (glR $1) [mj AnnStock $1] cs))) } + | 'anyclass' {% fmap Just $ acs (\cs -> sL1 $1 (AnyclassStrategy (ApiAnn (glR $1) [mj AnnAnyclass $1] cs))) } + | 'newtype' {% fmap Just $ acs (\cs -> sL1 $1 (NewtypeStrategy (ApiAnn (glR $1) [mj AnnNewtype $1] cs))) } | deriv_strategy_via { Just $1 } | {- empty -} { Nothing } -- Injective type families -opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn GhcPs)) } +opt_injective_info :: { Located ([AddApiAnn], Maybe (LInjectivityAnn GhcPs)) } : {- empty -} { noLoc ([], Nothing) } | '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1] , Just ($2)) } injectivity_cond :: { LInjectivityAnn GhcPs } : tyvarid '->' inj_varids - {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3)))) - [mu AnnRarrow $2] } + {% acs (\cs -> sLL (reLocN $1) $> (InjectivityAnn (ApiAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) } -inj_varids :: { Located [Located RdrName] } - : inj_varids tyvarid { sLL $1 $> ($2 : unLoc $1) } - | tyvarid { sLL $1 $> [$1] } +inj_varids :: { Located [LocatedN RdrName] } + : inj_varids tyvarid { sLL $1 (reLocN $>) ($2 : unLoc $1) } + | tyvarid { sL1N $1 [$1] } -- Closed type families -where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) } +where_type_family :: { Located ([AddApiAnn],FamilyInfo GhcPs) } : {- empty -} { noLoc ([],OpenTypeFamily) } | 'where' ty_fam_inst_eqn_list { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2) ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) } -ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } +ty_fam_inst_eqn_list :: { Located ([AddApiAnn],Maybe [LTyFamInstEqn GhcPs]) } : '{' ty_fam_inst_eqns '}' { sLL $1 $> ([moc $1,mcc $3] ,Just (unLoc $2)) } | vocurly ty_fam_inst_eqns close { let (L loc _) = $2 in @@ -1368,27 +1397,29 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) } ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } : ty_fam_inst_eqns ';' ty_fam_inst_eqn - {% let (L loc (anns, eqn)) = $3 in - asl (unLoc $1) $2 (L loc eqn) - >> ams $3 anns - >> return (sLL $1 $> (L loc eqn : unLoc $1)) } - | ty_fam_inst_eqns ';' {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (sLL $1 $> (unLoc $1)) } - | ty_fam_inst_eqn {% let (L loc (anns, eqn)) = $1 in - ams $1 anns - >> return (sLL $1 $> [L loc eqn]) } + {% let (L loc eqn) = $3 in + case unLoc $1 of + [] -> return (sLLlA $1 $> (L loc eqn : unLoc $1)) + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (sLLlA $1 $> ($3 : h' : t)) } + | ty_fam_inst_eqns ';' {% case unLoc $1 of + [] -> return (sLL $1 $> (unLoc $1)) + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (sLL $1 $> (h':t)) } + | ty_fam_inst_eqn { sLLAA $1 $> [$1] } | {- empty -} { noLoc [] } -ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } +ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs } : 'forall' tv_bndrs '.' type '=' ktype {% do { hintExplicitForall $1 ; tvbs <- fromSpecTyVarBndrs $2 - ; (eqn,ann) <- mkTyFamInstEqn (mkHsOuterExplicit tvbs) $4 $6 - ; return (sLL $1 $> - (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } } + ; let loc = comb2A $1 $> + ; cs <- getCommentsFor loc + ; mkTyFamInstEqn loc (mkHsOuterExplicit (ApiAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }} | type '=' ktype - {% do { (eqn,ann) <- mkTyFamInstEqn mkHsOuterImplicit $1 $3 - ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn)) } } + {% mkTyFamInstEqn (comb2A (reLoc $1) $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) } -- Note the use of type for the head; this allows -- infix type constructors and type patterns @@ -1404,40 +1435,38 @@ ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } at_decl_cls :: { LHsDecl GhcPs } : -- data family declarations, with optional 'family' keyword 'data' opt_family type opt_datafam_kind_sig - {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3 - (snd $ unLoc $4) Nothing)) - (mj AnnData $1:$2++(fst $ unLoc $4)) } + {% liftM mkTyClD (mkFamDecl (comb3 $1 (reLoc $3) $4) DataFamily NotTopLevel $3 + (snd $ unLoc $4) Nothing + (mj AnnData $1:$2++(fst $ unLoc $4))) } -- type family declarations, with optional 'family' keyword -- (can't use opt_instance because you get shift/reduce errors | 'type' type opt_at_kind_inj_sig - {% amms (liftM mkTyClD - (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 + {% liftM mkTyClD + (mkFamDecl (comb3 $1 (reLoc $2) $3) OpenTypeFamily NotTopLevel $2 (fst . snd $ unLoc $3) - (snd . snd $ unLoc $3))) - (mj AnnType $1:(fst $ unLoc $3)) } + (snd . snd $ unLoc $3) + (mj AnnType $1:(fst $ unLoc $3)) )} | 'type' 'family' type opt_at_kind_inj_sig - {% amms (liftM mkTyClD - (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3 + {% liftM mkTyClD + (mkFamDecl (comb3 $1 (reLoc $3) $4) OpenTypeFamily NotTopLevel $3 (fst . snd $ unLoc $4) - (snd . snd $ unLoc $4))) - (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) } + (snd . snd $ unLoc $4) + (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))} -- default type instances, with optional 'instance' keyword | 'type' ty_fam_inst_eqn - {% ams $2 (fst $ unLoc $2) >> - amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2))) - (mj AnnType $1:(fst $ unLoc $2)) } + {% liftM mkInstD (mkTyFamInst (comb2A $1 $2) (unLoc $2) + [mj AnnType $1]) } | 'type' 'instance' ty_fam_inst_eqn - {% ams $3 (fst $ unLoc $3) >> - amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))) - (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) } + {% liftM mkInstD (mkTyFamInst (comb2A $1 $3) (unLoc $3) + (mj AnnType $1:mj AnnInstance $2:[]) )} -opt_family :: { [AddAnn] } +opt_family :: { [AddApiAnn] } : {- empty -} { [] } | 'family' { [mj AnnFamily $1] } -opt_instance :: { [AddAnn] } +opt_instance :: { [AddApiAnn] } : {- empty -} { [] } | 'instance' { [mj AnnInstance $1] } @@ -1448,55 +1477,54 @@ at_decl_inst :: { LInstDecl GhcPs } : 'type' opt_instance ty_fam_inst_eqn -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% ams $3 (fst $ unLoc $3) >> - amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)) - (mj AnnType $1:$2++(fst $ unLoc $3)) } + {% mkTyFamInst (comb2A $1 $3) (unLoc $3) + (mj AnnType $1:$2) } -- data/newtype instance declaration, with optional 'instance' keyword | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4) + {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4) Nothing (reverse (snd $ unLoc $5)) - (fmap reverse $6)) - ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) } + (fmap reverse $6) + ((fst $ unLoc $1):$2++(fst $ unLoc $5)) } -- GADT instance declaration, with optional 'instance' keyword | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig gadt_constrlist maybe_derivings - {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 - (snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6) - (fmap reverse $7)) - ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) } + {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 + (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6) + (fmap reverse $7) + ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) } -data_or_newtype :: { Located (AddAnn, NewOrData) } +data_or_newtype :: { Located (AddApiAnn, NewOrData) } : 'data' { sL1 $1 (mj AnnData $1,DataType) } | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } -- Family result/return kind signatures -opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) } +opt_kind_sig :: { Located ([AddApiAnn], Maybe (LHsKind GhcPs)) } : { noLoc ([] , Nothing) } - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], Just $2) } + | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], Just $2) } -opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } +opt_datafam_kind_sig :: { Located ([AddApiAnn], LFamilyResultSig GhcPs) } : { noLoc ([] , noLoc (NoSig noExtField) )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))} + | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))} -opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } +opt_tyfam_kind_sig :: { Located ([AddApiAnn], LFamilyResultSig GhcPs) } : { noLoc ([] , noLoc (NoSig noExtField) )} - | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))} + | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))} | '=' tv_bndr {% do { tvb <- fromSpecTyVarBndr $2 - ; return $ sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExtField tvb))} } + ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLL $1 (reLoc $>) (TyVarSig noExtField tvb))} } -opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs +opt_at_kind_inj_sig :: { Located ([AddApiAnn], ( LFamilyResultSig GhcPs , Maybe (LInjectivityAnn GhcPs)))} : { noLoc ([], (noLoc (NoSig noExtField), Nothing)) } - | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] - , (sLL $2 $> (KindSig noExtField $2), Nothing)) } + | '::' kind { sLL $1 (reLoc $>) ( [mu AnnDcolon $1] + , (sL1A $> (KindSig noExtField $2), Nothing)) } | '=' tv_bndr_no_braces '|' injectivity_cond {% do { tvb <- fromSpecTyVarBndr $2 ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] - , (sLL $1 $2 (TyVarSig noExtField tvb), Just $4))} } + , (sLL $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} } -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -1506,39 +1534,36 @@ opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs -- T Int [a] -- for associated types -- Rather a lot of inlining here, else we get reduce/reduce errors tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) } - : context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> (return (sLL $1 $> (Just $1, $3))) - } - | type { sL1 $1 (Nothing, $1) } + : context '=>' type {% acs (\cs -> (sLLAA $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) } + | type { sL1A $1 (Nothing, $1) } -datafam_inst_hdr :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) } +datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) } : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1 >> fromSpecTyVarBndrs $2 - >>= \tvbs -> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5) - >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] - , (Just $4, mkHsOuterExplicit tvbs, $6))) - ) + >>= \tvbs -> + (acs (\cs -> (sLL $1 (reLoc $>) + (Just ( addTrailingDarrowC $4 $5 cs) + , mkHsOuterExplicit (ApiAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) noCom) tvbs, $6)))) } | 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1 ; tvbs <- fromSpecTyVarBndrs $2 - ; return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] - , (Nothing, mkHsOuterExplicit tvbs, $4))) + ; let loc = comb2 $1 (reLoc $>) + ; cs <- getCommentsFor loc + ; return (sL loc (Nothing, mkHsOuterExplicit (ApiAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4)) } } - | context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> (return (sLL $1 $>([], (Just $1, mkHsOuterImplicit, $3)))) - } - | type { sL1 $1 ([], (Nothing, mkHsOuterImplicit, $1)) } + | context '=>' type {% acs (\cs -> (sLLAA $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) } + | type { sL1A $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (Located CType) } +capi_ctype :: { Maybe (LocatedP CType) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% ajs (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) + {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2))) (getSTRINGs $3,getSTRING $3))) - [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] } + (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) } | '{-# CTYPE' STRING '#-}' - {% ajs (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))) - [mo $1,mj AnnVal $2,mc $3] } + {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2))) + (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) } | { Nothing } @@ -1550,17 +1575,16 @@ stand_alone_deriving :: { LDerivDecl GhcPs } : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type {% do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr $5) } - ; ams (sLL $1 $> - (DerivDecl noExtField (mkHsWildCardBndrs $5) $2 $4)) - [mj AnnDeriving $1, mj AnnInstance $3] } } + ; acsA (\cs -> sLL $1 (reLoc $>) + (DerivDecl (ApiAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }} ----------------------------------------------------------------------------- -- Role annotations role_annot :: { LRoleAnnotDecl GhcPs } role_annot : 'type' 'role' oqtycon maybe_roles - {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4))) - [mj AnnType $1,mj AnnRole $2] } + {% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4)) + [mj AnnType $1,mj AnnRole $2] } -- Reversed! maybe_roles :: { Located [Located (Maybe FastString)] } @@ -1581,52 +1605,51 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 } -- Glasgow extension: pattern synonyms pattern_synonym_decl :: { LHsDecl GhcPs } : 'pattern' pattern_synonym_lhs '=' pat - {% let (name, args,as ) = $2 in - ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 - ImplicitBidirectional) - (as ++ [mj AnnPattern $1, mj AnnEqual $3]) - } + {% let (name, args, as ) = $2 in + acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4 + ImplicitBidirectional + (ApiAnn (glR $1) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) } | 'pattern' pattern_synonym_lhs '<-' pat {% let (name, args, as) = $2 in - ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional) - (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) } + acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4 Unidirectional + (ApiAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) } | 'pattern' pattern_synonym_lhs '<-' pat where_decls {% do { let (name, args, as) = $2 - ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) - ; ams (sLL $1 $> . ValD noExtField $ - mkPatSynBind name args $4 (ExplicitBidirectional mg)) - (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) ) + ; mg <- mkPatSynMatchGroup name $5 + ; acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ + mkPatSynBind name args $4 (ExplicitBidirectional mg) + (ApiAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }} -pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails GhcPs, [AddAnn]) } +pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddApiAnn]) } : con vars0 { ($1, PrefixCon noTypeArgs $2, []) } | varid conop varid { ($2, InfixCon $1 $3, []) } | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) } -vars0 :: { [Located RdrName] } +vars0 :: { [LocatedN RdrName] } : {- empty -} { [] } | varid vars0 { $1 : $2 } cvars1 :: { [RecordPatSynField GhcPs] } : var { [RecordPatSynField (mkFieldOcc $1) $1] } - | var ',' cvars1 {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >> - return ((RecordPatSynField (mkFieldOcc $1) $1) : $3 )} + | var ',' cvars1 {% do { h <- addTrailingCommaN $1 (gl $2) + ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}} -where_decls :: { Located ([AddAnn] - , Located (OrdList (LHsDecl GhcPs))) } - : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 - :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) } - | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3)) - ,sL1 $3 (snd $ unLoc $3)) } +where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) } + : 'where' '{' decls '}' {% amsrl (sLL $1 $> (snd $ unLoc $3)) + (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) } + | 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3)) + (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))} pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype - {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) $4) - [mj AnnPattern $1, mu AnnDcolon $3] } + {% acsA (\cs -> sLL $1 (reLoc $>) + $ PatSynSig (ApiAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs) + (unLoc $2) $4) } -qvarcon :: { Located RdrName } +qvarcon :: { LocatedN RdrName } : qvar { $1 } | qcon { $1 } @@ -1645,26 +1668,30 @@ decl_cls : at_decl_cls { $1 } do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> quotes (ppr $2) - ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $4) - [mj AnnDefault $1,mu AnnDcolon $3] } } + ; acsA (\cs -> sLL $1 (reLoc $>) $ SigD noExtField $ ClassOpSig (ApiAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }} -decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed +decls_cls :: { Located ([AddApiAnn],OrdList (LHsDecl GhcPs)) } -- Reversed : decls_cls ';' decl_cls {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + then return (sLLlA $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1) , unitOL $3)) - else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] - >> return (sLL $1 $> (fst $ unLoc $1 - ,(snd $ unLoc $1) `appOL` unitOL $3)) } + else case (snd $ unLoc $1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (sLLlA $1 $> (fst $ unLoc $1 + , snocOL hs t' `appOL` unitOL $3)) } | decls_cls ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + then return (sLL $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1) ,snd $ unLoc $1)) - else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl_cls { sL1 $1 ([], unitOL $1) } + else case (snd $ unLoc $1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (sLL $1 $> (fst $ unLoc $1 + , snocOL hs t')) } + | decl_cls { sL1A $1 ([], unitOL $1) } | {- empty -} { noLoc ([],nilOL) } decllist_cls - :: { Located ([AddAnn] + :: { Located ([AddApiAnn] , OrdList (LHsDecl GhcPs) , LayoutInfo) } -- Reversed : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) @@ -1674,7 +1701,7 @@ decllist_cls -- Class body -- -where_cls :: { Located ([AddAnn] +where_cls :: { Located ([AddApiAnn] ,(OrdList (LHsDecl GhcPs)) -- Reversed ,LayoutInfo) } -- No implicit parameters @@ -1686,34 +1713,38 @@ where_cls :: { Located ([AddAnn] -- Declarations in instance bodies -- decl_inst :: { Located (OrdList (LHsDecl GhcPs)) } -decl_inst : at_decl_inst { sLL $1 $> (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) } - | decl { sLL $1 $> (unitOL $1) } +decl_inst : at_decl_inst { sL1A $1 (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) } + | decl { sL1A $1 (unitOL $1) } -decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed +decls_inst :: { Located ([AddApiAnn],OrdList (LHsDecl GhcPs)) } -- Reversed : decls_inst ';' decl_inst {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + then return (sLL $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1) , unLoc $3)) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return - (sLL $1 $> (fst $ unLoc $1 - ,(snd $ unLoc $1) `appOL` unLoc $3)) } + else case (snd $ unLoc $1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (sLL $1 $> (fst $ unLoc $1 + , snocOL hs t' `appOL` unLoc $3)) } | decls_inst ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + then return (sLL $1 $> ((mz AnnSemi $2) ++ (fst $ unLoc $1) ,snd $ unLoc $1)) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } + else case (snd $ unLoc $1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (sLL $1 $> (fst $ unLoc $1 + , snocOL hs t')) } | decl_inst { sL1 $1 ([],unLoc $1) } | {- empty -} { noLoc ([],nilOL) } decllist_inst - :: { Located ([AddAnn] + :: { Located ([AddApiAnn] , OrdList (LHsDecl GhcPs)) } -- Reversed : '{' decls_inst '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) } | vocurly decls_inst close { L (gl $2) (unLoc $2) } -- Instance body -- -where_inst :: { Located ([AddAnn] +where_inst :: { Located ([AddApiAnn] , OrdList (LHsDecl GhcPs)) } -- Reversed -- No implicit parameters -- May have type declarations @@ -1723,78 +1754,89 @@ where_inst :: { Located ([AddAnn] -- Declarations in binding groups other than classes and instances -- -decls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } +decls :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) } : decls ';' decl {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) + then return (sLLlA $1 $> ((msemi $2) ++ (fst $ unLoc $1) , unitOL $3)) - else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return ( - let { this = unitOL $3; - rest = snd $ unLoc $1; - these = rest `appOL` this } - in rest `seq` this `seq` these `seq` - (sLL $1 $> (fst $ unLoc $1,these))) } + else case (snd $ unLoc $1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + let { this = unitOL $3; + rest = snocOL hs t'; + these = rest `appOL` this } + return (rest `seq` this `seq` these `seq` + (sLLlA $1 $> (fst $ unLoc $1, these))) } | decls ';' {% if isNilOL (snd $ unLoc $1) - then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1) + then return (sLL $1 $> (((msemi $2) ++ (fst $ unLoc $1) ,snd $ unLoc $1))) - else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2] - >> return (sLL $1 $> (unLoc $1)) } - | decl { sL1 $1 ([], unitOL $1) } + else case (snd $ unLoc $1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (sLL $1 $> (fst $ unLoc $1 + , snocOL hs t')) } + | decl { sL1A $1 ([], unitOL $1) } | {- empty -} { noLoc ([],nilOL) } -decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) } - : '{' decls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) +decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) } + : '{' decls '}' { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2) + ,sL1 $2 $ snd $ unLoc $2) } + | vocurly decls close { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2) ,sL1 $2 $ snd $ unLoc $2) } - | vocurly decls close { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) } -- Binding groups other than those of class and instance declarations -- -binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } +binds :: { Located (HsLocalBinds GhcPs) } -- May have implicit parameters -- No type declarations : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) - ; return (sL1 $1 (fst $ unLoc $1 - ,sL1 $1 $ HsValBinds noExtField val_binds)) } } + ; cs <- getCommentsFor (gl $1) + ; if (isNilOL (unLoc $ snd $ unLoc $1)) + then return (sL1 $1 $ HsValBinds (ApiAnn (glR $1) (AnnList (Just $ glR $1) Nothing Nothing [] []) cs) val_binds) + else return (sL1 $1 $ HsValBinds (ApiAnn (glR $1) (fst $ unLoc $1) cs) val_binds) } } - | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } + | '{' dbinds '}' {% acs (\cs -> (L (comb3 $1 $2 $3) + $ HsIPBinds (ApiAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } - | vocurly dbinds close { L (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) } + | vocurly dbinds close {% acs (\cs -> (L (gl $2) + $ HsIPBinds (ApiAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) } -wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } +wherebinds :: { Maybe (Located (HsLocalBinds GhcPs)) } -- May have implicit parameters -- No type declarations - : 'where' binds { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2) - ,snd $ unLoc $2) } - | {- empty -} { noLoc ([],noLoc emptyLocalBinds) } - + : 'where' binds { Just (sLL $1 $> (annBinds (mj AnnWhere $1) (unLoc $2))) } + | {- empty -} { Nothing } ----------------------------------------------------------------------------- -- Transformation Rules -rules :: { OrdList (LRuleDecl GhcPs) } - : rules ';' rule {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `snocOL` $3) } - | rules ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } - | rule { unitOL $1 } - | {- empty -} { nilOL } +rules :: { [LRuleDecl GhcPs] } -- Reversed + : rules ';' rule {% case $1 of + [] -> return ($3:$1) + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return ($3:h':t) } + | rules ';' {% case $1 of + [] -> return $1 + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (h':t) } + | rule { [$1] } + | {- empty -} { [] } rule :: { LRuleDecl GhcPs } : STRING rule_activation rule_foralls infixexp '=' exp {%runPV (unECP $4) >>= \ $4 -> runPV (unECP $6) >>= \ $6 -> - ams (sLL $1 $> $ HsRule { rd_ext = noExtField + acsA (\cs -> (sLLlA $1 $> $ HsRule + { rd_ext = ApiAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 - , rd_lhs = $4, rd_rhs = $6 }) - (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) } + , rd_lhs = $4, rd_rhs = $6 })) } -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas -rule_activation :: { ([AddAnn],Maybe Activation) } +rule_activation :: { ([AddApiAnn],Maybe Activation) } -- See Note [%shift: rule_activation -> {- empty -}] : {- empty -} %shift { ([],Nothing) } | rule_explicit_activation { (fst $1,Just (snd $1)) } @@ -1807,14 +1849,14 @@ rule_activation :: { ([AddAnn],Maybe Activation) } -- without a space [~1] (the PREFIX_TILDE case), or -- with a space [~ 1] (the VARSYM case). -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer -rule_activation_marker :: { [AddAnn] } +rule_activation_marker :: { [AddApiAnn] } : PREFIX_TILDE { [mj AnnTilde $1] } | VARSYM {% if (getVARSYM $1 == fsLit "~") then return [mj AnnTilde $1] else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc $1) ; return [] } } -rule_explicit_activation :: { ([AddAnn] +rule_explicit_activation :: { ([AddApiAnn] ,Activation) } -- In brackets : '[' INTEGER ']' { ([mos $1,mj AnnVal $2,mcs $3] ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } @@ -1825,28 +1867,29 @@ rule_explicit_activation :: { ([AddAnn] { ($2++[mos $1,mcs $3] ,NeverActive) } -rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) } +rule_foralls :: { ([AddApiAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) } : 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2 in hintExplicitForall $1 >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2) - >> return ([mu AnnForall $1,mj AnnDot $3, - mu AnnForall $4,mj AnnDot $6], + >> return (\anns -> HsRuleAnn + (Just (mu AnnForall $1,mj AnnDot $3)) + (Just (mu AnnForall $4,mj AnnDot $6)) + anns, Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) } -- See Note [%shift: rule_foralls -> 'forall' rule_vars '.'] - | 'forall' rule_vars '.' %shift { ([mu AnnForall $1,mj AnnDot $3], + | 'forall' rule_vars '.' %shift { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns, Nothing, mkRuleBndrs $2) } -- See Note [%shift: rule_foralls -> {- empty -}] - | {- empty -} %shift { ([], Nothing, []) } + | {- empty -} %shift { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) } rule_vars :: { [LRuleTyTmVar] } : rule_var rule_vars { $1 : $2 } | {- empty -} { [] } rule_var :: { LRuleTyTmVar } - : varid { sLL $1 $> (RuleTyTmVar $1 Nothing) } - | '(' varid '::' ctype ')' {% ams (sLL $1 $> (RuleTyTmVar $2 (Just $4))) - [mop $1,mu AnnDcolon $3,mcp $5] } + : varid { sL1N $1 (RuleTyTmVar noAnn $1 Nothing) } + | '(' varid '::' ctype ')' {% acs (\cs -> sLL $1 $> (RuleTyTmVar (ApiAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) } {- Note [Parsing explicit foralls in Rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1875,42 +1918,66 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. -- Warnings and deprecations (c.f. rules) warnings :: { OrdList (LWarnDecl GhcPs) } - : warnings ';' warning {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `appOL` $3) } - | warnings ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } + : warnings ';' warning {% if isNilOL $1 + then return ($1 `appOL` $3) + else case $1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (snocOL hs t' `appOL` $3) } + | warnings ';' {% if isNilOL $1 + then return $1 + else case $1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (snocOL hs t') } | warning { $1 } | {- empty -} { nilOL } -- SUP: TEMPORARY HACK, not checking for `module Foo' warning :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% amsu (sLL $1 $> (Warning noExtField (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) - (fst $ unLoc $2) } + {% fmap unitOL $ acsA (\cs -> sLL $1 $> + (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) + (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) } deprecations :: { OrdList (LWarnDecl GhcPs) } : deprecations ';' deprecation - {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return ($1 `appOL` $3) } - | deprecations ';' {% addAnnotation (oll $1) AnnSemi (gl $2) - >> return $1 } + {% if isNilOL $1 + then return ($1 `appOL` $3) + else case $1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (snocOL hs t' `appOL` $3) } + | deprecations ';' {% if isNilOL $1 + then return $1 + else case $1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (gl $2) + return (snocOL hs t') } | deprecation { $1 } | {- empty -} { nilOL } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LWarnDecl GhcPs) } : namelist strings - {% amsu (sLL $1 $> $ (Warning noExtField (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) - (fst $ unLoc $2) } + {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (ApiAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1) + (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) } -strings :: { Located ([AddAnn],[Located StringLiteral]) } +strings :: { Located ([AddApiAnn],[Located StringLiteral]) } : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } stringlist :: { Located (OrdList (Located StringLiteral)) } - : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> (unLoc $1 `snocOL` - (L (gl $3) (getStringLiteral $3)))) } + : stringlist ',' STRING {% if isNilOL (unLoc $1) + then return (sLL $1 $> (unLoc $1 `snocOL` + (L (gl $3) (getStringLiteral $3)))) + else case (unLoc $1) of + SnocOL hs t -> do + let { t' = addTrailingCommaS t (glAA $2) } + return (sLL $1 $> (snocOL hs t' `snocOL` + (L (gl $3) (getStringLiteral $3)))) + +} | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } | {- empty -} { noLoc nilOL } @@ -1918,28 +1985,27 @@ stringlist :: { Located (OrdList (Located StringLiteral)) } -- Annotations annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> - ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField + acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation + (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs) (getANN_PRAGs $1) - (ValueAnnProvenance $2) $3)) - [mo $1,mc $4] } + (ValueAnnProvenance $2) $3)) } | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> - ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField + acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation + (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs) (getANN_PRAGs $1) - (TypeAnnProvenance $3) $4)) - [mo $1,mj AnnType $2,mc $5] } + (TypeAnnProvenance $3) $4)) } | '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> - ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField + acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation + (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs) (getANN_PRAGs $1) - ModuleAnnProvenance $3)) - [mo $1,mj AnnModule $2,mc $4] } - + ModuleAnnProvenance $3)) } ----------------------------------------------------------------------------- -- Foreign import and export declarations -fdecl :: { Located ([AddAnn],HsDecl GhcPs) } +fdecl :: { Located ([AddApiAnn],ApiAnn -> HsDecl GhcPs) } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } @@ -1962,13 +2028,13 @@ safety :: { Located Safety } | 'safe' { sLL $1 $> PlaySafe } | 'interruptible' { sLL $1 $> PlayInterruptible } -fspec :: { Located ([AddAnn] - ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) } - : STRING var '::' sigtype { sLL $1 $> ([mu AnnDcolon $3] +fspec :: { Located ([AddApiAnn] + ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) } + : STRING var '::' sigtype { sLL $1 (reLoc $>) ([mu AnnDcolon $3] ,(L (getLoc $1) (getStringLiteral $1), $2, $4)) } - | var '::' sigtype { sLL $1 $> ([mu AnnDcolon $2] - ,(noLoc (StringLiteral NoSourceText nilFS), $1, $3)) } + | var '::' sigtype { sLL (reLocN $1) (reLoc $>) ([mu AnnDcolon $2] + ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) } -- if the entity string is missing, it defaults to the empty string; -- the meaning of an empty entity string depends on the calling -- convention @@ -1976,11 +2042,11 @@ fspec :: { Located ([AddAnn] ----------------------------------------------------------------------------- -- Type signatures -opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) } - : {- empty -} { ([],Nothing) } - | '::' ctype { ([mu AnnDcolon $1],Just $2) } +opt_sig :: { Maybe (AddApiAnn, LHsType GhcPs) } + : {- empty -} { Nothing } + | '::' ctype { Just (mu AnnDcolon $1, $2) } -opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } +opt_tyconsig :: { ([AddApiAnn], Maybe (LocatedN RdrName)) } : {- empty -} { ([], Nothing) } | '::' gtycon { ([mu AnnDcolon $1], Just $2) } @@ -1988,9 +2054,8 @@ opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } -- See Note [forall-or-nothing rule] in GHC.Hs.Type. sigktype :: { LHsSigType GhcPs } : sigtype { $1 } - | ctype '::' kind {% ams (sLL $1 $> $ mkHsImplicitSigType $ - sLL $1 $> $ HsKindSig noExtField $1 $3) - [mu AnnDcolon $2] } + | ctype '::' kind {% acsA (\cs -> sLLAA $1 $> $ mkHsImplicitSigType $ + sLLa (reLoc $1) (reLoc $>) $ HsKindSig (ApiAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) } -- Like ctype, but for types that obey the forall-or-nothing rule. -- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the @@ -1999,17 +2064,18 @@ sigktype :: { LHsSigType GhcPs } sigtype :: { LHsSigType GhcPs } : ctype { hsTypeToHsSigType $1 } -sig_vars :: { Located [Located RdrName] } -- Returned in reversed order - : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) - AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | var { sL1 $1 [$1] } +sig_vars :: { Located [LocatedN RdrName] } -- Returned in reversed order + : sig_vars ',' var {% case unLoc $1 of + [] -> return (sLL $1 (reLocN $>) ($3 : unLoc $1)) + (h:t) -> do + h' <- addTrailingCommaN h (gl $2) + return (sLL $1 (reLocN $>) ($3 : h' : t)) } + | var { sL1N $1 [$1] } -sigtypes1 :: { (OrdList (LHsSigType GhcPs)) } +sigtypes1 :: { OrdList (LHsSigType GhcPs) } : sigtype { unitOL $1 } - | sigtype ',' sigtypes1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return (unitOL $1 `appOL` $3) } - + | sigtype ',' sigtypes1 {% do { st <- addTrailingCommaA $1 (gl $2) + ; return $ unitOL st `appOL` $3 } } ----------------------------------------------------------------------------- -- Types @@ -2017,37 +2083,32 @@ unpackedness :: { Located UnpackednessPragma } : '{-# UNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) } | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) } -forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) } +forall_telescope :: { Located (HsForAllTelescope GhcPs) } : 'forall' tv_bndrs '.' {% do { hintExplicitForall $1 - ; pure $ sLL $1 $> - ( [mu AnnForall $1, mu AnnDot $3] - , mkHsForAllInvisTele $2 ) }} + ; acs (\cs -> (sLL $1 $> $ + mkHsForAllInvisTele (ApiAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }} | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1 ; req_tvbs <- fromSpecTyVarBndrs $2 - ; pure $ sLL $1 $> $ - ( [mu AnnForall $1, mu AnnRarrow $3] - , mkHsForAllVisTele req_tvbs ) }} + ; acs (\cs -> (sLL $1 $> $ + mkHsForAllVisTele (ApiAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }} -- A ktype is a ctype, possibly with a kind annotation ktype :: { LHsType GhcPs } : ctype { $1 } - | ctype '::' kind {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3) - [mu AnnDcolon $2] } + | ctype '::' kind {% acsA (\cs -> sLLAA $1 $> $ HsKindSig (ApiAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) } + -- A ctype is a for-all type ctype :: { LHsType GhcPs } - : forall_telescope ctype {% let (forall_anns, forall_tele) = unLoc $1 in - ams (sLL $1 $> $ - HsForAllTy { hst_tele = forall_tele + : forall_telescope ctype { reLocA $ sLL $1 (reLoc $>) $ + HsForAllTy { hst_tele = unLoc $1 , hst_xforall = noExtField - , hst_body = $2 }) - forall_anns } - | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) - >> return (sLL $1 $> $ - HsQualTy { hst_ctxt = Just $1 - , hst_xqual = noExtField - , hst_body = $3 }) } - | ipvar '::' type {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3)) - [mu AnnDcolon $2] } + , hst_body = $2 } } + | context '=>' ctype {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $ + HsQualTy { hst_ctxt = Just (addTrailingDarrowC $1 $2 cs) + , hst_xqual = NoExtField + , hst_body = $3 })) } + + | ipvar '::' type {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (ApiAnn (glR $1) [mu AnnDcolon $2] cs) $1 $3)) } | type { $1 } ---------------------- @@ -2058,12 +2119,7 @@ ctype :: { LHsType GhcPs } -- looks so much like a tuple type. We can't tell until we find the => context :: { LHsContext GhcPs } - : btype {% do { (anns,ctx) <- checkContext $1 - ; if null (unLoc ctx) - then addAnnotation (gl $1) AnnUnit (gl $1) - else return () - ; ams ctx anns - } } + : btype {% checkContext $1 } {- Note [GADT decl discards annotations] ~~~~~~~~~~~~~~~~~~~~~ @@ -2084,38 +2140,36 @@ is connected to the first type too. type :: { LHsType GhcPs } -- See Note [%shift: type -> btype] : btype %shift { $1 } - | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See Note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField (HsUnrestrictedArrow (toUnicode $2)) $1 $3) - [mu AnnRarrow $2] } + | btype '->' ctype {% acsA (\cs -> sLL (reLoc $1) (reLoc $>) + $ HsFunTy (ApiAnn (glAR $1) (mau $2) cs) (HsUnrestrictedArrow (toUnicode $2)) $1 $3) } | btype mult '->' ctype {% hintLinear (getLoc $2) - >> let (arr, ann) = (unLoc $2) (toUnicode $3) - in (ams $1 [ann,mu AnnRarrow $3] -- See Note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField arr $1 $4) - [ann,mu AnnRarrow $3]) } + >> let arr = (unLoc $2) (toUnicode $3) + in acsA (\cs -> sLL (reLoc $1) (reLoc $>) + $ HsFunTy (ApiAnn (glAR $1) (mau $3) cs) arr $1 $4) } - | btype '->.' ctype {% hintLinear (getLoc $2) - >> ams $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations] - >> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3) - [mu AnnLollyU $2] } + | btype '->.' ctype {% hintLinear (getLoc $2) >> + acsA (\cs -> sLL (reLoc $1) (reLoc $>) + $ HsFunTy (ApiAnn (glAR $1) (mau $2) cs) (HsLinearArrow UnicodeSyntax Nothing) $1 $3) } + -- [mu AnnLollyU $2] } -mult :: { Located (IsUnicodeSyntax -> (HsArrow GhcPs, AddAnn)) } - : PREFIX_PERCENT atype { sLL $1 $> (\u -> mkMultTy u $1 $2) } +mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) } + : PREFIX_PERCENT atype { sLL $1 (reLoc $>) (\u -> mkMultTy u $1 $2) } btype :: { LHsType GhcPs } : infixtype {% runPV $1 } -infixtype :: { forall b. DisambTD b => PV (Located b) } +infixtype :: { forall b. DisambTD b => PV (LocatedA b) } -- See Note [%shift: infixtype -> ftype] : ftype %shift { $1 } | ftype tyop infixtype { $1 >>= \ $1 -> $3 >>= \ $3 -> - do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLoc $2) + do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2) ; mkHsOpTyPV $1 $2 $3 } } | unpackedness infixtype { $2 >>= \ $2 -> mkUnpackednessPV $1 $2 } -ftype :: { forall b. DisambTD b => PV (Located b) } +ftype :: { forall b. DisambTD b => PV (LocatedA b) } : atype { mkHsAppTyHeadPV $1 } | tyop { failOpFewArgs $1 } | ftype tyarg { $1 >>= \ $1 -> @@ -2127,74 +2181,61 @@ tyarg :: { LHsType GhcPs } : atype { $1 } | unpackedness atype {% addUnpackednessP $1 $2 } -tyop :: { Located RdrName } +tyop :: { LocatedN RdrName } : qtyconop { $1 } | tyvarop { $1 } - | SIMPLEQUOTE qconop {% ams (sLL $1 $> (unLoc $2)) - [mj AnnSimpleQuote $1,mj AnnVal $2] } - | SIMPLEQUOTE varop {% ams (sLL $1 $> (unLoc $2)) - [mj AnnSimpleQuote $1,mj AnnVal $2] } + | SIMPLEQUOTE qconop {% amsrn (sLL $1 (reLoc $>) (unLoc $2)) + (NameAnnQuote (glAA $1) (gl $2) []) } + | SIMPLEQUOTE varop {% amsrn (sLL $1 (reLoc $>) (unLoc $2)) + (NameAnnQuote (glAA $1) (gl $2) []) } atype :: { LHsType GhcPs } - : ntgtycon { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- Not including unit tuples + : ntgtycon {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] cs) NotPromoted $1)) } -- Not including unit tuples -- See Note [%shift: atype -> tyvar] - | tyvar %shift { sL1 $1 (HsTyVar noExtField NotPromoted $1) } -- (See Note [Unit tuples]) + | tyvar %shift {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (ApiAnn (glNR $1) [] cs) NotPromoted $1)) } -- (See Note [Unit tuples]) | '*' {% do { warnStarIsType (getLoc $1) - ; return $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } } + ; return $ reLocA $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer - | PREFIX_TILDE atype {% ams (sLL $1 $> (mkBangTy SrcLazy $2)) [mj AnnTilde $1] } - | PREFIX_BANG atype {% ams (sLL $1 $> (mkBangTy SrcStrict $2)) [mj AnnBang $1] } + | PREFIX_TILDE atype {% acsA (\cs -> sLLlA $1 $> (mkBangTy (ApiAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) } + | PREFIX_BANG atype {% acsA (\cs -> sLLlA $1 $> (mkBangTy (ApiAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) } - | '{' fielddecls '}' {% amms (checkRecordSyntax - (sLL $1 $> $ HsRecTy noExtField $2)) + | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (ApiAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2)) + ; checkRecordSyntax decls }} -- Constructor sigs only - [moc $1,mcc $3] } - | '(' ')' {% ams (sLL $1 $> $ HsTupleTy noExtField - HsBoxedOrConstraintTuple []) - [mop $1,mcp $2] } - | '(' ktype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma - (gl $3) >> - ams (sLL $1 $> $ HsTupleTy noExtField - - HsBoxedOrConstraintTuple ($2 : $4)) - [mop $1,mcp $5] } - | '(#' '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple []) - [mo $1,mc $2] } - | '(#' comma_types1 '#)' {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple $2) - [mo $1,mc $3] } - | '(#' bar_types2 '#)' {% ams (sLL $1 $> $ HsSumTy noExtField $2) - [mo $1,mc $3] } - | '[' ktype ']' {% ams (sLL $1 $> $ HsListTy noExtField $2) [mos $1,mcs $3] } - | '(' ktype ')' {% ams (sLL $1 $> $ HsParTy noExtField $2) [mop $1,mcp $3] } - | quasiquote { mapLoc (HsSpliceTy noExtField) $1 } - | splice_untyped { mapLoc (HsSpliceTy noExtField) $1 } + | '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs) + HsBoxedOrConstraintTuple []) } + | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3) + ; acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $5)) cs) + HsBoxedOrConstraintTuple (h : $4)) }} + | '(#' '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) } + | '(#' comma_types1 '#)' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) } + | '(#' bar_types2 '#)' {% acsA (\cs -> sLL $1 $> $ HsSumTy (ApiAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) } + | '[' ktype ']' {% acsA (\cs -> sLL $1 $> $ HsListTy (ApiAnn (glR $1) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) } + | '(' ktype ')' {% acsA (\cs -> sLL $1 $> $ HsParTy (ApiAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $3)) cs) $2) } + | quasiquote { mapLocA (HsSpliceTy noExtField) $1 } + | splice_untyped { mapLocA (HsSpliceTy noExtField) $1 } -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) } | SIMPLEQUOTE '(' ktype ',' comma_types1 ')' - {% addAnnotation (gl $3) AnnComma (gl $4) >> - ams (sLL $1 $> $ HsExplicitTupleTy noExtField ($3 : $5)) - [mj AnnSimpleQuote $1,mop $2,mcp $6] } - | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExtField IsPromoted $3) - [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) - [mj AnnSimpleQuote $1,mj AnnName $2] } + {% do { h <- addTrailingCommaA $3 (gl $4) + ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }} + | SIMPLEQUOTE '[' comma_types0 ']' {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) } + | SIMPLEQUOTE var {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (ApiAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) } -- Two or more [ty, ty, ty] must be a promoted list type, just as -- if you had written '[ty, ty, ty] -- (One means a list type, zero means the list type constructor, -- so you have to quote those.) - | '[' ktype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma - (gl $3) >> - ams (sLL $1 $> $ HsExplicitListTy noExtField NotPromoted ($2 : $4)) - [mos $1,mcs $5] } - | INTEGER { sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1) + | '[' ktype ',' comma_types1 ']' {% do { h <- addTrailingCommaA $2 (gl $3) + ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (ApiAnn (glR $1) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }} + | INTEGER { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1) (il_value (getINTEGER $1)) } - | CHAR { sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1) + | CHAR { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1) (getCHAR $1) } - | STRING { sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1) + | STRING { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1) (getSTRING $1) } - | '_' { sL1 $1 $ mkAnonWildCardTy } + | '_' { reLocA $ sL1 $1 $ mkAnonWildCardTy } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -2205,8 +2246,8 @@ inst_type :: { LHsSigType GhcPs } deriv_types :: { [LHsSigType GhcPs] } : sigktype { [$1] } - | sigktype ',' deriv_types {% addAnnotation (gl $1) AnnComma (gl $2) - >> return ($1 : $3) } + | sigktype ',' deriv_types {% do { h <- addTrailingCommaA $1 (gl $2) + ; return (h : $3) } } comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty : comma_types1 { $1 } @@ -2214,14 +2255,14 @@ comma_types0 :: { [LHsType GhcPs] } -- Zero or more: ty,ty,ty comma_types1 :: { [LHsType GhcPs] } -- One or more: ty,ty,ty : ktype { [$1] } - | ktype ',' comma_types1 {% addAnnotation (gl $1) AnnComma (gl $2) - >> return ($1 : $3) } + | ktype ',' comma_types1 {% do { h <- addTrailingCommaA $1 (gl $2) + ; return (h : $3) }} bar_types2 :: { [LHsType GhcPs] } -- Two or more: ty|ty|ty - : ktype '|' ktype {% addAnnotation (gl $1) AnnVbar (gl $2) - >> return [$1,$3] } - | ktype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2) - >> return ($1 : $3) } + : ktype '|' ktype {% do { h <- addTrailingVbarA $1 (gl $2) + ; return [h,$3] }} + | ktype '|' bar_types2 {% do { h <- addTrailingVbarA $1 (gl $2) + ; return (h : $3) }} tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] } : tv_bndr tv_bndrs { $1 : $2 } @@ -2229,36 +2270,34 @@ tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] } tv_bndr :: { LHsTyVarBndr Specificity GhcPs } : tv_bndr_no_braces { $1 } - | '{' tyvar '}' {% ams (sLL $1 $> (UserTyVar noExtField InferredSpec $2)) - [moc $1, mcc $3] } - | '{' tyvar '::' kind '}' {% ams (sLL $1 $> (KindedTyVar noExtField InferredSpec $2 $4)) - [moc $1,mu AnnDcolon $3 - ,mcc $5] } + | '{' tyvar '}' {% acsA (\cs -> sLL $1 $> (UserTyVar (ApiAnn (glR $1) [mop $1, mcp $3] cs) InferredSpec $2)) } + | '{' tyvar '::' kind '}' {% acsA (\cs -> sLL $1 $> (KindedTyVar (ApiAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) InferredSpec $2 $4)) } tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs } - : tyvar { sL1 $1 (UserTyVar noExtField SpecifiedSpec $1) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExtField SpecifiedSpec $2 $4)) - [mop $1,mu AnnDcolon $3 - ,mcp $5] } + : tyvar {% acsA (\cs -> (sL1 (reLocN $1) (UserTyVar (ApiAnn (glNR $1) [] cs) SpecifiedSpec $1))) } + | '(' tyvar '::' kind ')' {% acsA (\cs -> (sLL $1 $> (KindedTyVar (ApiAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) } -fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) } +fds :: { Located ([AddApiAnn],[LHsFunDep GhcPs]) } : {- empty -} { noLoc ([],[]) } | '|' fds1 { (sLL $1 $> ([mj AnnVbar $1] ,reverse (unLoc $2))) } -fds1 :: { Located [Located (FunDep (Located RdrName))] } - : fds1 ',' fd {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | fd { sL1 $1 [$1] } +fds1 :: { Located [LHsFunDep GhcPs] } + : fds1 ',' fd {% + do { let (h:t) = unLoc $1 -- Safe from fds1 rules + ; h' <- addTrailingCommaA h (gl $2) + ; return (sLLlA $1 $> ($3 : h' : t)) }} + | fd { sL1A $1 [$1] } -fd :: { Located (FunDep (Located RdrName)) } - : varids0 '->' varids0 {% ams (L (comb3 $1 $2 $3) - (reverse (unLoc $1), reverse (unLoc $3))) - [mu AnnRarrow $2] } +fd :: { LHsFunDep GhcPs } + : varids0 '->' varids0 {% acsA (\cs -> L (comb3 $1 $2 $3) + (FunDep (ApiAnn (glR $1) [mu AnnRarrow $2] cs) + (reverse (unLoc $1)) + (reverse (unLoc $3)))) } -varids0 :: { Located [Located RdrName] } +varids0 :: { Located [LocatedN RdrName] } : {- empty -} { noLoc [] } - | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) } + | varids0 tyvar { sLL $1 (reLocN $>) ($2 : (unLoc $1)) } ----------------------------------------------------------------------------- -- Kinds @@ -2291,7 +2330,7 @@ And both become a HsTyVar ("Zero", DataName) after the renamer. ----------------------------------------------------------------------------- -- Datatype declarations -gadt_constrlist :: { Located ([AddAnn] +gadt_constrlist :: { Located ([AddApiAnn] ,[LConDecl GhcPs]) } -- Returned in order : 'where' '{' gadt_constrs '}' {% checkEmptyGADTs $ @@ -2308,9 +2347,9 @@ gadt_constrlist :: { Located ([AddAnn] gadt_constrs :: { Located [LConDecl GhcPs] } : gadt_constr ';' gadt_constrs - {% addAnnotation (gl $1) AnnSemi (gl $2) - >> return (L (comb2 $1 $3) ($1 : unLoc $3)) } - | gadt_constr { L (gl $1) [$1] } + {% do { h <- addTrailingSemiA $1 (gl $2) + ; return (L (comb2 (reLoc $1) $3) (h : unLoc $3)) }} + | gadt_constr { L (glA $1) [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -2322,10 +2361,9 @@ gadt_constrs :: { Located [LConDecl GhcPs] } gadt_constr :: { LConDecl GhcPs } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty + -- TODO:AZ capture the optSemi. Why leading? : optSemi con_list '::' sigtype - {% do { (decl, anns) <- mkGadtDecl (unLoc $2) $4 - ; ams (sLL $2 $> decl) - (mu AnnDcolon $3:anns) } } + {% mkGadtDecl (comb2A $2 $>) (unLoc $2) $4 [mu AnnDcolon $3] } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2339,39 +2377,42 @@ consequence, GADT constructor names are restricted (names like '(*)' are allowed in usual data constructors, but not in GADTs). -} -constrs :: { Located ([AddAnn],[LConDecl GhcPs]) } +constrs :: { Located ([AddApiAnn],[LConDecl GhcPs]) } : '=' constrs1 { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)} constrs1 :: { Located [LConDecl GhcPs] } : constrs1 '|' constr - {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) - >> return (sLL $1 $> ($3 : unLoc $1)) } - | constr { sL1 $1 [$1] } + {% do { let (h:t) = unLoc $1 + ; h' <- addTrailingVbarA h (gl $2) + ; return (sLLlA $1 $> ($3 : h' : t)) }} + | constr { sL1A $1 [$1] } constr :: { LConDecl GhcPs } : forall context '=>' constr_stuff - {% ams (let (con,details) = unLoc $4 in - (L (comb4 $1 $2 $3 $4) (mkConDeclH98 con - (snd $ unLoc $1) - (Just $2) - details))) - (mu AnnDarrow $3:(fst $ unLoc $1)) } + {% acsA (\cs -> let (con,details) = unLoc $4 in + (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98 + (ApiAnn (spanAsAnchor (comb4 $1 (reLoc $2) $3 $4)) + (mu AnnDarrow $3:(fst $ unLoc $1)) cs) + con + (snd $ unLoc $1) + (Just $2) + details))) } | forall constr_stuff - {% ams (let (con,details) = unLoc $2 in - (L (comb2 $1 $2) (mkConDeclH98 con - (snd $ unLoc $1) - Nothing -- No context - details))) - (fst $ unLoc $1) } - -forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) } + {% acsA (\cs -> let (con,details) = unLoc $2 in + (L (comb2 $1 $2) (mkConDeclH98 (ApiAnn (spanAsAnchor (comb2 $1 $2)) (fst $ unLoc $1) cs) + con + (snd $ unLoc $1) + Nothing -- No context + details))) } + +forall :: { Located ([AddApiAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) } : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } | {- empty -} { noLoc ([], Nothing) } -constr_stuff :: { Located (Located RdrName, HsConDeclH98Details GhcPs) } - : infixtype {% fmap (mapLoc (\b -> (dataConBuilderCon b, - dataConBuilderDetails b))) - (runPV $1) } +constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) } + : infixtype {% fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b, + dataConBuilderDetails b)))) + (runPV $1) } fielddecls :: { [LConDeclField GhcPs] } : {- empty -} { [] } @@ -2379,53 +2420,50 @@ fielddecls :: { [LConDeclField GhcPs] } fielddecls1 :: { [LConDeclField GhcPs] } : fielddecl ',' fielddecls1 - {% addAnnotation (gl $1) AnnComma (gl $2) >> - return ($1 : $3) } + {% do { h <- addTrailingCommaA $1 (gl $2) + ; return (h : $3) }} | fielddecl { [$1] } fielddecl :: { LConDeclField GhcPs } -- A list because of f,g :: Int : sig_vars '::' ctype - {% ams (L (comb2 $1 $3) - (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing)) - [mu AnnDcolon $2] } + {% acsA (\cs -> L (comb2 $1 (reLoc $3)) + (ConDeclField (ApiAnn (glR $1) [mu AnnDcolon $2] cs) + (reverse (map (\ln@(L l n) -> L (locA l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))} -- Reversed! -maybe_derivings :: { HsDeriving GhcPs } +maybe_derivings :: { Located (HsDeriving GhcPs) } : {- empty -} { noLoc [] } | derivings { $1 } -- A list of one or more deriving clauses at the end of a datatype -derivings :: { HsDeriving GhcPs } - : derivings deriving { sLL $1 $> $ $2 : unLoc $1 } +derivings :: { Located (HsDeriving GhcPs) } + : derivings deriving { sLL $1 $> ($2 : unLoc $1) } -- AZ: order? | deriving { sLL $1 $> [$1] } -- The outer Located is just to allow the caller to -- know the rightmost extremity of the 'deriving' clause deriving :: { LHsDerivingClause GhcPs } : 'deriving' deriv_clause_types - {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExtField Nothing $2) - [mj AnnDeriving $1] } + {% let { full_loc = comb2A $1 $> } + in acs (\cs -> L full_loc $ HsDerivingClause (ApiAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) } | 'deriving' deriv_strategy_no_via deriv_clause_types - {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3) - [mj AnnDeriving $1] } + {% let { full_loc = comb2A $1 $> } + in acs (\cs -> L full_loc $ HsDerivingClause (ApiAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) } | 'deriving' deriv_clause_types deriv_strategy_via {% let { full_loc = comb2 $1 $> } - in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2) - [mj AnnDeriving $1] } + in acs (\cs -> L full_loc $ HsDerivingClause (ApiAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) } deriv_clause_types :: { LDerivClauseTys GhcPs } - : qtycon { let { tc = sL1 $1 $ mkHsImplicitSigType $ - sL1 $1 $ HsTyVar noExtField NotPromoted $1 } in - sL1 $1 (DctSingle noExtField tc) } - | '(' ')' {% ams (sLL $1 $> (DctMulti noExtField [])) - [mop $1,mcp $2] } - | '(' deriv_types ')' {% ams (sLL $1 $> (DctMulti noExtField $2)) - [mop $1,mcp $3] } + : qtycon { let { tc = sL1 (reLocL $1) $ mkHsImplicitSigType $ + sL1 (reLocL $1) $ HsTyVar noAnn NotPromoted $1 } in + sL1 (reLocC $1) (DctSingle noExtField tc) } + | '(' ')' {% amsrc (sLL $1 $> (DctMulti noExtField [])) + (AnnContext Nothing [glAA $1] [glAA $2]) } + | '(' deriv_types ')' {% amsrc (sLL $1 $> (DctMulti noExtField $2)) + (AnnContext Nothing [glAA $1] [glAA $3])} ----------------------------------------------------------------------------- -- Value definitions @@ -2456,18 +2494,13 @@ decl_no_th :: { LHsDecl GhcPs } : sigdecl { $1 } | infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 -> - do { (ann,r) <- checkValDef $1 (snd $2) $3; - let { l = comb2 $1 $> }; + do { let { l = comb2Al $1 $> } + ; r <- checkValDef l $1 $2 $3; -- Depending upon what the pattern looks like we might get either -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] - case r of { - (FunBind _ n _ _) -> - amsL l (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind _ (L lh _lhs) _rhs _) -> - amsL lh (fst $2) >> return () } ; - _ <- amsL l (ann ++ (fst $ unLoc $3)); - return $! (sL l $ ValD noExtField r) } } + ; cs <- getCommentsFor l + ; return $! (sL (commentsA l cs) $ ValD noExtField r) } } | pattern_synonym_decl { $1 } decl :: { LHsDecl GhcPs } @@ -2476,17 +2509,16 @@ decl :: { LHsDecl GhcPs } -- Why do we only allow naked declaration splices in top-level -- declarations and not here? Short answer: because readFail009 -- fails terribly with a panic in cvBindsAndSigs otherwise. - | splice_exp { sLL $1 $> $ mkSpliceDecl $1 } - -rhs :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) } - : '=' exp wherebinds {% runPV (unECP $2) >>= \ $2 -> return $ - sL (comb3 $1 $2 $3) - ((mj AnnEqual $1 : (fst $ unLoc $3)) - ,GRHSs noExtField (unguardedRHS (comb3 $1 $2 $3) $2) - (snd $ unLoc $3)) } - | gdrhs wherebinds { sLL $1 $> (fst $ unLoc $2 - ,GRHSs noExtField (reverse (unLoc $1)) - (snd $ unLoc $2)) } + | splice_exp {% mkSpliceDecl $1 } + +rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) } + : '=' exp wherebinds {% runPV (unECP $2) >>= \ $2 -> + do { let loc = (comb3 $1 (reLoc $2) (adaptWhereBinds $3)) + ; acs (\cs -> + sL loc (GRHSs NoExtField (unguardedRHS (ApiAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2) + (unLoc $ (adaptWhereBinds $3)))) } } + | gdrhs wherebinds { sL (comb2 $1 (adaptWhereBinds $>)) + (GRHSs noExtField (reverse (unLoc $1)) (unLoc $ (adaptWhereBinds $2))) } gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } @@ -2494,8 +2526,7 @@ gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } : '|' guardquals '=' exp {% runPV (unECP $4) >>= \ $4 -> - ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4) - [mj AnnVbar $1,mj AnnEqual $3] } + acs (\cs -> sL (comb2A $1 $>) $ GRHS (ApiAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) } sigdecl :: { LHsDecl GhcPs } : @@ -2503,79 +2534,68 @@ sigdecl :: { LHsDecl GhcPs } infixexp '::' sigtype {% do { $1 <- runPV (unECP $1) ; v <- checkValSigLhs $1 - ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2] - ; return (sLL $1 $> $ SigD noExtField $ - TypeSig noExtField [v] (mkHsWildCardBndrs $3))} } + ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $ + TypeSig (ApiAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} } | var ',' sig_vars '::' sigtype - {% do { let sig = TypeSig noExtField ($1 : reverse (unLoc $3)) - (mkHsWildCardBndrs $5) - ; addAnnotation (gl $1) AnnComma (gl $2) - ; ams ( sLL $1 $> $ SigD noExtField sig ) - [mu AnnDcolon $4] } } + {% do { v <- addTrailingCommaN $1 (gl $2) + ; let sig cs = TypeSig (ApiAnn (glNR $1) (AnnSig (mu AnnDcolon $4) []) cs) (v : reverse (unLoc $3)) + (mkHsWildCardBndrs $5) + ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }} | infix prec ops {% checkPrecP $2 $3 >> - ams (sLL $1 $> $ SigD noExtField - (FixSig noExtField (FixitySig noExtField (fromOL $ unLoc $3) - (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) - [mj AnnInfix $1,mj AnnVal $2] } + acsA (\cs -> sLL $1 $> $ SigD noExtField + (FixSig (ApiAnn (glR $1) [mj AnnInfix $1,mj AnnVal $2] cs) (FixitySig noExtField (fromOL $ unLoc $3) + (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) } - | pattern_synonym_sig { sLL $1 $> . SigD noExtField . unLoc $ $1 } + | pattern_synonym_sig { sL1 $1 . SigD noExtField . unLoc $ $1 } | '{-# COMPLETE' con_list opt_tyconsig '#-}' {% let (dcolon, tc) = $3 - in ams - (sLL $1 $> - (SigD noExtField (CompleteMatchSig noExtField (getCOMPLETE_PRAGs $1) $2 tc))) - ([ mo $1 ] ++ dcolon ++ [mc $4]) } + in acsA + (\cs -> sLL $1 $> + (SigD noExtField (CompleteMatchSig (ApiAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs) (getCOMPLETE_PRAGs $1) $2 tc))) } -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvarcon '#-}' - {% ams ((sLL $1 $> $ SigD noExtField (InlineSig noExtField $3 + {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (ApiAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3 (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) - (snd $2))))) - ((mo $1:fst $2) ++ [mc $4]) } + (snd $2))))) } | '{-# SCC' qvar '#-}' - {% ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 Nothing))) - [mo $1, mc $3] } + {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (ApiAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) } | '{-# SCC' qvar STRING '#-}' {% do { scc <- getSCC $3 - ; let str_lit = StringLiteral (getSTRINGs $3) scc - ; ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) - [mo $1, mc $4] } } + ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing + ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (ApiAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) }} | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' - {% ams ( + {% acsA (\cs -> let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) (NoUserInlinePrag, FunLike) (snd $2) - in sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) inl_prag)) - (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } + in sLL $1 $> $ SigD noExtField (SpecSig (ApiAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - {% ams (sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) + {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (ApiAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) (mkInlinePragma (getSPEC_INLINE_PRAGs $1) - (getSPEC_INLINE $1) (snd $2)))) - (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } + (getSPEC_INLINE $1) (snd $2)))) } | '{-# SPECIALISE' 'instance' inst_type '#-}' - {% ams (sLL $1 $> - $ SigD noExtField (SpecInstSig noExtField (getSPEC_PRAGs $1) $3)) - [mo $1,mj AnnInstance $2,mc $4] } + {% acsA (\cs -> sLL $1 $> + $ SigD noExtField (SpecInstSig (ApiAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs) (getSPEC_PRAGs $1) $3)) } -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}' - {% ams (sLL $1 $> $ SigD noExtField (MinimalSig noExtField (getMINIMAL_PRAGs $1) $2)) - [mo $1,mc $3] } + {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig (ApiAnn (glR $1) [mo $1,mc $3] cs) (getMINIMAL_PRAGs $1) $2)) } -activation :: { ([AddAnn],Maybe Activation) } - : -- See Note [%shift: activation -> {- empty -}] - {- empty -} %shift { ([],Nothing) } +activation :: { ([AddApiAnn],Maybe Activation) } + -- See Note [%shift: activation -> {- empty -}] + : {- empty -} %shift { ([],Nothing) } | explicit_activation { (fst $1,Just (snd $1)) } -explicit_activation :: { ([AddAnn],Activation) } -- In brackets +explicit_activation :: { ([AddApiAnn],Activation) } -- In brackets : '[' INTEGER ']' { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3] ,ActiveAfter (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) } | '[' rule_activation_marker INTEGER ']' @@ -2593,39 +2613,35 @@ quasiquote :: { Located (HsSplice GhcPs) } | TH_QQUASIQUOTE { let { loc = getLoc $1 ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkQual varName (qual, quoter) } - in sL (getLoc $1) (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } + in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) } exp :: { ECP } : infixexp '::' ctype { ECP $ unECP $1 >>= \ $1 -> rejectPragmaPV $1 >> - amms (mkHsTySigPV (comb2 $1 $>) $1 $3) - [mu AnnDcolon $2] } + mkHsTySigPV (noAnnSrcSpan $ comb2Al $1 (reLoc $>)) $1 $3 + [(mu AnnDcolon $2)] } | infixexp '-<' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3 - HsFirstOrderApp True) - [mu Annlarrowtail $2] } + acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3 + HsFirstOrderApp True) } | infixexp '>-' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1 - HsFirstOrderApp False) - [mu Annrarrowtail $2] } + acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1 + HsFirstOrderApp False) } | infixexp '-<<' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3 - HsHigherOrderApp True) - [mu AnnLarrowtail $2] } + acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3 + HsHigherOrderApp True) } | infixexp '>>-' exp {% runPV (unECP $1) >>= \ $1 -> runPV (unECP $3) >>= \ $3 -> fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1 - HsHigherOrderApp False) - [mu AnnRarrowtail $2] } + acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (ApiAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1 + HsHigherOrderApp False) } -- See Note [%shift: exp -> infixexp] | infixexp %shift { $1 } | exp_prag(exp) { $1 } -- See Note [Pragmas and operator fixity] @@ -2639,8 +2655,7 @@ infixexp :: { ECP } unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> rejectPragmaPV $1 >> - amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3) - [mj AnnVal $2] } + (mkHsOpAppPV (comb2A (reLoc $1) $3) $1 $2 $3) } -- AnnVal annotation for NPlusKPat, which discards the operator exp10p :: { ECP } @@ -2651,15 +2666,14 @@ exp_prag(e) :: { ECP } : prag_e e -- See Note [Pragmas and operator fixity] {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2) - (fst $ unLoc $1) } + return $ (reLocA $ sLLlA $1 $> $ HsPragE noExtField (unLoc $1) $2) } exp10 :: { ECP } -- See Note [%shift: exp10 -> '-' fexp] : '-' fexp %shift { ECP $ unECP $2 >>= \ $2 -> - amms (mkHsNegAppPV (comb2 $1 $>) $2) - [mj AnnMinus $1] } + mkHsNegAppPV (comb2A $1 $>) $2 + [mj AnnMinus $1] } -- See Note [%shift: exp10 -> fexp] | fexp %shift { $1 } @@ -2712,33 +2726,34 @@ may sound unnecessary, but it's actually needed to support a common idiom: f $ {-# SCC ann $-} ... -} -prag_e :: { Located ([AddAnn], HsPragE GhcPs) } - : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 - ; return $ sLL $1 $> - ([mo $1,mj AnnValStr $2,mc $3], - HsPragSCC noExtField +prag_e :: { Located (HsPragE GhcPs) } + : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2 + ; acs (\cs -> (sLL $1 $> + (HsPragSCC + (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs) (getSCC_PRAGs $1) - (StringLiteral (getSTRINGs $2) scc)) } - | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3], - HsPragSCC noExtField - (getSCC_PRAGs $1) - (StringLiteral NoSourceText (getVARID $2))) } + (StringLiteral (getSTRINGs $2) scc Nothing))))} } + | '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $> + (HsPragSCC + (ApiAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs) + (getSCC_PRAGs $1) + (StringLiteral NoSourceText (getVARID $2) Nothing)))) } + fexp :: { ECP } : fexp aexp { ECP $ superFunArg $ unECP $1 >>= \ $1 -> unECP $2 >>= \ $2 -> - mkHsAppPV (comb2 $1 $>) $1 $2 } + mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc $1) $>) $1 $2 } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer | fexp PREFIX_AT atype { ECP $ unECP $1 >>= \ $1 -> - amms (mkHsAppTypePV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } + mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (getLoc $2) $3 } | 'static' aexp {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - ams (sLL $1 $> $ HsStatic noExtField $2) - [mj AnnStatic $1] } + acsA (\cs -> sLL $1 (reLoc $>) $ HsStatic (ApiAnn (glR $1) [mj AnnStatic $1] cs) $2) } | aexp { $1 } @@ -2747,83 +2762,78 @@ aexp :: { ECP } : qvar TIGHT_INFIX_AT aexp { ECP $ unECP $3 >>= \ $3 -> - amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] } + mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 $3 [mj AnnAt $2] } + -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer | PREFIX_TILDE aexp { ECP $ unECP $2 >>= \ $2 -> - amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] } + mkHsLazyPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnTilde $1] } | PREFIX_BANG aexp { ECP $ unECP $2 >>= \ $2 -> - amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] } + mkHsBangPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnBang $1] } | PREFIX_MINUS aexp { ECP $ unECP $2 >>= \ $2 -> - amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] } + mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] } | '\\' apat apats '->' exp { ECP $ unECP $5 >>= \ $5 -> - amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource - [sLL $1 $> $ Match { m_ext = noExtField - , m_ctxt = LambdaExpr - , m_pats = $2:$3 - , m_grhss = unguardedGRHSs $5 }])) - [mj AnnLam $1, mu AnnRarrow $4] } + mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource + (reLocA $ sLLlA $1 $> + [reLocA $ sLLlA $1 $> + $ Match { m_ext = ApiAnn (glR $1) [mj AnnLam $1] cs + , m_ctxt = LambdaExpr + , m_pats = $2:$3 + , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (ApiAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) noCom) }])) } | 'let' binds 'in' exp { ECP $ unECP $4 >>= \ $4 -> - amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4) - (mj AnnLet $1:mj AnnIn $3 - :(fst $ unLoc $2)) } + mkHsLetPV (comb2A $1 $>) (unLoc $2) $4 + (AnnsLet (glAA $1) (glAA $3)) } | '\\' 'lcase' altslist { ECP $ $3 >>= \ $3 -> - amms (mkHsLamCasePV (comb2 $1 $>) - (mkMatchGroup FromSource (snd $ unLoc $3))) - (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) } + mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] } | 'if' exp optSemi 'then' exp optSemi 'else' exp - {% runPV (unECP $2) >>= \ $2 -> + {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) -> return $ ECP $ unECP $5 >>= \ $5 -> unECP $8 >>= \ $8 -> - amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8) - (mj AnnIf $1:mj AnnThen $4 + mkHsIfPV (comb2A $1 $>) $2 (snd $3) $5 (snd $6) $8 + (mj AnnIf $1:mj AnnThen $4 :mj AnnElse $7 - :(map (\l -> mj AnnSemi l) (fst $3)) - ++(map (\l -> mj AnnSemi l) (fst $6))) } + :(concatMap (\l -> mz AnnSemi l) (fst $3)) + ++(concatMap (\l -> mz AnnSemi l) (fst $6))) } + | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>= \_ -> fmap ecpFromExp $ - ams (sLL $1 $> $ HsMultiIf noExtField - (reverse $ snd $ unLoc $2)) - (mj AnnIf $1:(fst $ unLoc $2)) } - | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ $2 -> + acsA (\cs -> sLL $1 $> $ HsMultiIf (ApiAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs) + (reverse $ snd $ unLoc $2)) } + | 'case' exp 'of' altslist {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) -> return $ ECP $ $4 >>= \ $4 -> - amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup - FromSource (snd $ unLoc $4))) - (mj AnnCase $1:mj AnnOf $3 - :(fst $ unLoc $4)) } + mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4 + (ApiAnnHsCase (glAA $1) (glAA $3) []) } -- QualifiedDo. | DO stmtlist {% do hintQualifiedDo $1 return $ ECP $ $2 >>= \ $2 -> - amms (mkHsDoPV (comb2 $1 $2) - (fmap mkModuleNameFS (getDO $1)) - (mapLoc snd $2)) - (mj AnnDo $1:(fst $ unLoc $2)) } + mkHsDoPV (comb2A $1 $2) + (fmap mkModuleNameFS (getDO $1)) + $2 + (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnDo $1] []) } | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> fmap ecpFromExp $ - ams (L (comb2 $1 $2) - (mkHsDo (MDoExpr $ - fmap mkModuleNameFS (getMDO $1)) - (snd $ unLoc $2))) - (mj AnnMdo $1:(fst $ unLoc $2)) } + acsA (\cs -> L (comb2A $1 $2) + (mkHsDoAnns (MDoExpr $ + fmap mkModuleNameFS (getMDO $1)) + $2 + (ApiAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) } | 'proc' aexp '->' exp {% (checkPattern <=< runPV) (unECP $2) >>= \ p -> runPV (unECP $4) >>= \ $4@cmd -> fmap ecpFromExp $ - ams (sLL $1 $> $ HsProc noExtField p (sLL $1 $> $ HsCmdTop noExtField cmd)) - -- TODO: is LL right here? - [mj AnnProc $1,mu AnnRarrow $3] } + acsA (\cs -> sLLlA $1 $> $ HsProc (ApiAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLlA $1 $> $ HsCmdTop noExtField cmd)) } | aexp1 { $1 } @@ -2832,14 +2842,17 @@ aexp1 :: { ECP } getBit OverloadedRecordUpdateBit >>= \ overloaded -> unECP $1 >>= \ $1 -> $3 >>= \ $3 -> - amms (mkHsRecordPV overloaded (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3)) - (moc $2:mcc $4:(fst $3)) + mkHsRecordPV overloaded (comb2 (reLoc $1) $>) (comb2 $2 $4) $1 $3 + [moc $2,mcc $4] } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer | aexp1 TIGHT_INFIX_PROJ field {% runPV (unECP $1) >>= \ $1 -> - fmap ecpFromExp $ ams (mkRdrGetField (comb2 $1 $>) $1 $3) [mj AnnDot $2] } + fmap ecpFromExp $ acsa (\cs -> + let fl = sLL $2 $> (HsFieldLabel ((ApiAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) noCom)) $3) in + mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (ApiAnn (glAR $1) NoApiAnns cs)) } + | aexp2 { $1 } @@ -2847,15 +2860,15 @@ aexp2 :: { ECP } : qvar { ECP $ mkHsVarPV $! $1 } | qcon { ECP $ mkHsVarPV $! $1 } -- See Note [%shift: aexp2 -> ipvar] - | ipvar %shift { ecpFromExp $ sL1 $1 (HsIPVar noExtField $! unLoc $1) } - | overloaded_label { ecpFromExp $ sL1 $1 (HsOverLabel noExtField $! unLoc $1) } - | literal { ECP $ mkHsLitPV $! $1 } + | ipvar %shift {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) } + | overloaded_label {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) $! unLoc $1)) } + | literal { ECP $ pvA (mkHsLitPV $! $1) } -- This will enable overloaded strings permanently. Normally the renamer turns HsString -- into HsOverLit when -foverloaded-strings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) -- (getSTRING $1) noExtField) } - | INTEGER { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) } - | RATIONAL { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) } + | INTEGER { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) } + | RATIONAL { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't @@ -2863,104 +2876,94 @@ aexp2 :: { ECP } -- but the less cluttered version fell out of having texps. | '(' texp ')' { ECP $ unECP $2 >>= \ $2 -> - amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] } + mkHsParPV (comb2 $1 $>) $2 (AnnParen AnnParens (glAA $1) (glAA $3)) } | '(' tup_exprs ')' { ECP $ $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2)) - ((mop $1:fst $2) ++ [mcp $3]) } + mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2 + [mop $1,mcp $3]} -- This case is only possible when 'OverloadedRecordDotBit' is enabled. | '(' projection ')' { ECP $ - let (loc, (anns, fIELDS)) = $2 - span = combineSrcSpans (combineSrcSpans (getLoc $1) loc) (getLoc $3) - expr = mkRdrProjection span (reverse fIELDS) - in amms (ecpFromExp' expr) ([mop $1] ++ reverse anns ++ [mcp $3]) + acsA (\cs -> sLL $1 $> $ mkRdrProjection (reverse (unLoc $2)) (ApiAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs)) + >>= ecpFromExp' } | '(#' texp '#)' { ECP $ unECP $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)])) - [mo $1,mc $3] } + mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2]) + [moh $1,mch $3] } | '(#' tup_exprs '#)' { ECP $ $2 >>= \ $2 -> - amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (snd $2)) - ((mo $1:fst $2) ++ [mc $3]) } + mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2 + [moh $1,mch $3] } - | '[' list ']' { ECP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] } - | '_' { ECP $ mkHsWildCardPV (getLoc $1) } + | '[' list ']' { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) } + | '_' { ECP $ pvA $ mkHsWildCardPV (getLoc $1) } -- Template Haskell Extension - | splice_untyped { ECP $ mkHsSplicePV $1 } - | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noExtField) $1 } + | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 } + | splice_typed { ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA $1) } - | SIMPLEQUOTE qvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } + | SIMPLEQUOTE qcon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True $2)) } + | TH_TY_QUOTE tyvar {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) } + | TH_TY_QUOTE gtycon {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (ApiAnn (glR $1) [mj AnnThTyQuote $1 ] cs) (VarBr noExtField False $2)) } -- See Note [%shift: aexp2 -> TH_TY_QUOTE] | TH_TY_QUOTE %shift {% reportEmptyDoubleQuotes (getLoc $1) } | '[|' exp '|]' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (ExpBr noExtField $2)) - (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] - else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) } + acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3] + else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) } | '[||' exp '||]' {% runPV (unECP $2) >>= \ $2 -> fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (TExpBr noExtField $2)) - (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } + acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) (TExpBr noExtField $2)) } | '[t|' ktype '|]' {% fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (TypBr noExtField $2)) [mo $1,mu AnnCloseQ $3] } + acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) } | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p -> fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (PatBr noExtField p)) - [mo $1,mu AnnCloseQ $3] } + acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) } | '[d|' cvtopbody '|]' {% fmap ecpFromExp $ - ams (sLL $1 $> $ HsBracket noExtField (DecBrL noExtField (snd $2))) - (mo $1:mu AnnCloseQ $3:fst $2) } - | quasiquote { ECP $ mkHsSplicePV $1 } + acsA (\cs -> sLL $1 $> $ HsBracket (ApiAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) } + | quasiquote { ECP $ pvA $ mkHsSplicePV $1 } -- arrow notation extension | '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 -> - fmap ecpFromCmd $ - ams (sLL $1 $> $ HsCmdArrForm noExtField $2 Prefix - Nothing (reverse $3)) - [mu AnnOpenB $1,mu AnnCloseB $4] } + fmap ecpFromCmd $ + acsA (\cs -> sLL $1 $> $ HsCmdArrForm (ApiAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix + Nothing (reverse $3)) } -projection :: { (SrcSpan, ([AddAnn], [Located FastString])) } +projection :: { Located [Located (HsFieldLabel GhcPs)] } projection -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer : projection TIGHT_INFIX_PROJ field - { let (loc, (anns, fs)) = $1 in - (combineSrcSpans (combineSrcSpans loc (gl $2)) (gl $3), (mj AnnDot $2 : anns, $3 : fs)) } - | PREFIX_PROJ field { (comb2 $1 $2, ([mj AnnDot $1], [$2])) } + {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) : unLoc $1)) } + | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> [sLL $1 $> $ HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2]) } splice_exp :: { LHsExpr GhcPs } - : splice_untyped { mapLoc (HsSpliceE noExtField) $1 } - | splice_typed { mapLoc (HsSpliceE noExtField) $1 } + : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) } + | splice_typed { mapLoc (HsSpliceE noAnn) (reLocA $1) } splice_untyped :: { Located (HsSplice GhcPs) } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer : PREFIX_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 -> - ams (sLL $1 $> $ mkUntypedSplice DollarSplice $2) - [mj AnnDollar $1] } + acs (\cs -> sLLlA $1 $> $ mkUntypedSplice (ApiAnn (glR $1) [mj AnnDollar $1] cs) DollarSplice $2) } splice_typed :: { Located (HsSplice GhcPs) } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer : PREFIX_DOLLAR_DOLLAR aexp2 {% runPV (unECP $2) >>= \ $2 -> - ams (sLL $1 $> $ mkTypedSplice DollarSplice $2) - [mj AnnDollarDollar $1] } + acs (\cs -> sLLlA $1 $> $ mkTypedSplice (ApiAnn (glR $1) [mj AnnDollarDollar $1] cs) DollarSplice $2) } cmdargs :: { [LHsCmdTop GhcPs] } : cmdargs acmd { $2 : $1 } | {- empty -} { [] } acmd :: { LHsCmdTop GhcPs } - : aexp {% runPV (unECP $1) >>= \ cmd -> + : aexp {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) -> runPV (checkCmdBlockArguments cmd) >>= \ _ -> - return (sL1 cmd $ HsCmdTop noExtField cmd) } + return (sL1A cmd $ HsCmdTop noExtField cmd) } -cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) } +cvtopbody :: { ([AddApiAnn],[LHsDecl GhcPs]) } : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 ,mj AnnCloseC $3],$2) } | vocurly cvtopdecls0 close { ([],$2) } @@ -2974,7 +2977,7 @@ cvtopdecls0 :: { [LHsDecl GhcPs] } -- "texp" is short for tuple expressions: -- things that can appear unparenthesized as long as they're --- inside parens or delimitted by commas +-- inside parens or delimited by commas texp :: { ECP } : exp { $1 } @@ -2994,62 +2997,58 @@ texp :: { ECP } runPV (rejectPragmaPV $1) >> runPV $2 >>= \ $2 -> return $ ecpFromExp $ - sLL $1 $> $ SectionL noExtField $1 $2 } + reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) } | qopm infixexp { ECP $ superInfixOp $ unECP $2 >>= \ $2 -> $1 >>= \ $1 -> - mkHsSectionR_PV (comb2 $1 $>) $1 $2 } + pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 } -- View patterns get parenthesized above | exp '->' texp { ECP $ unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> - amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] } + mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] } -- Always at least one comma or bar. -- Though this can parse just commas (without any expressions), it won't -- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple] -- in GHC.Hs.Expr. -tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) } +tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) } : texp commas_tup_tail { unECP $1 >>= \ $1 -> $2 >>= \ $2 -> - do { addAnnotation (gl $1) AnnComma (fst $2) - ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } } - - | texp bars { unECP $1 >>= \ $1 -> return $ - (mvbars (fst $2), Sum 1 (snd $2 + 1) $1) } - + do { t <- amsA $1 [AddCommaAnn (AR $ rs $ fst $2)] + ; return (Tuple (Right t : snd $2)) } } | commas tup_tail { $2 >>= \ $2 -> - do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1) - ; return - ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } } + do { let {cos = map (\ll -> (Left (ApiAnn (anc $ rs ll) (AR $ rs ll) noCom))) (fst $1) } + ; return (Tuple (cos ++ $2)) } } + + | texp bars { unECP $1 >>= \ $1 -> return $ + (Sum 1 (snd $2 + 1) $1 [] (fst $2)) } | bars texp bars0 { unECP $2 >>= \ $2 -> return $ - (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) } + (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) } -- Always starts with commas; always follows an expr -commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))]) } +commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (ApiAnn' AnnAnchor) (LocatedA b)]) } commas_tup_tail : commas tup_tail { $2 >>= \ $2 -> - do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1) - ; return ( - (head $ fst $1 - ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } } + do { let {cos = map (\l -> (Left (ApiAnn (anc $ rs l) (AR $ rs l) noCom))) (tail $ fst $1) } + ; return ((head $ fst $1, cos ++ $2)) } } -- Always follows a comma -tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } +tup_tail :: { forall b. DisambECP b => PV [Either (ApiAnn' AnnAnchor) (LocatedA b)] } : texp commas_tup_tail { unECP $1 >>= \ $1 -> $2 >>= \ $2 -> - addAnnotation (gl $1) AnnComma (fst $2) >> - return ((L (gl $1) (Just $1)) : snd $2) } + do { t <- amsA $1 [AddCommaAnn (AR $ rs $ fst $2)] + ; return (Right t : snd $2) } } | texp { unECP $1 >>= \ $1 -> - return [L (gl $1) (Just $1)] } + return [Right $1] } -- See Note [%shift: tup_tail -> {- empty -}] - | {- empty -} %shift { return [noLoc Nothing] } + | {- empty -} %shift { return [Left noAnn] } ----------------------------------------------------------------------------- -- List expressions @@ -3057,51 +3056,48 @@ tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] } -- The rules below are little bit contorted to keep lexps left-recursive while -- avoiding another shift/reduce-conflict. -- Never empty. -list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) } - : texp { \loc -> unECP $1 >>= \ $1 -> - mkHsExplicitListPV loc [$1] } - | lexps { \loc -> $1 >>= \ $1 -> - mkHsExplicitListPV loc (reverse $1) } - | texp '..' { \loc -> unECP $1 >>= \ $1 -> - ams (L loc $ ArithSeq noExtField Nothing (From $1)) - [mj AnnDotdot $2] +list :: { forall b. DisambECP b => SrcSpan -> (AddApiAnn, AddApiAnn) -> PV (LocatedA b) } + : texp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> + mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) } + | lexps { \loc (ao,ac) -> $1 >>= \ $1 -> + mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) } + | texp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> + acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (From $1)) >>= ecpFromExp' } - | texp ',' exp '..' { \loc -> + | texp ',' exp '..' { \loc (ao,ac) -> unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> - ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3)) - [mj AnnComma $2,mj AnnDotdot $4] + acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThen $1 $3)) >>= ecpFromExp' } - | texp '..' exp { \loc -> unECP $1 >>= \ $1 -> + | texp '..' exp { \loc (ao,ac) -> + unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> - ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3)) - [mj AnnDotdot $2] + acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (FromTo $1 $3)) >>= ecpFromExp' } - | texp ',' exp '..' exp { \loc -> + | texp ',' exp '..' exp { \loc (ao,ac) -> unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> unECP $5 >>= \ $5 -> - ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5)) - [mj AnnComma $2,mj AnnDotdot $4] + acsA (\cs -> L loc $ ArithSeq (ApiAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThenTo $1 $3 $5)) >>= ecpFromExp' } | texp '|' flattenedpquals - { \loc -> + { \loc (ao,ac) -> checkMonadComp >>= \ ctxt -> - unECP $1 >>= \ $1 -> - ams (L loc $ mkHsComp ctxt (unLoc $3) $1) - [mj AnnVbar $2] - >>= ecpFromExp' } + unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2) + ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc $3) t (ApiAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs)) + >>= ecpFromExp' } } -lexps :: { forall b. DisambECP b => PV [Located b] } +lexps :: { forall b. DisambECP b => PV [LocatedA b] } : lexps ',' texp { $1 >>= \ $1 -> unECP $3 >>= \ $3 -> - addAnnotation (gl $ head $ $1) - AnnComma (gl $2) >> - return (((:) $! $3) $! $1) } + case $1 of + (h:t) -> do + h' <- addTrailingCommaA h (gl $2) + return (((:) $! $3) $! (h':t)) } | texp ',' texp { unECP $1 >>= \ $1 -> unECP $3 >>= \ $3 -> - addAnnotation (gl $1) AnnComma (gl $2) >> - return [$3,$1] } + do { h <- addTrailingCommaA $1 (gl $2) + ; return [$3,h] }} ----------------------------------------------------------------------------- -- List Comprehensions @@ -3112,7 +3108,7 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> sL1 $1 [sL1 $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | + qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | qs <- qss] noExpr noSyntaxExpr] -- We actually found some actual parallel lists so @@ -3121,24 +3117,28 @@ flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] } : squals '|' pquals - {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >> - return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) } + {% case unLoc $1 of + (h:t) -> do + h' <- addTrailingVbarA h (gl $2) + return (sLL $1 $> (reverse (h':t) : unLoc $3)) } | squals { L (getLoc $1) [reverse (unLoc $1)] } squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual - {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - amsL (comb2 $1 $>) (fst $ unLoc $3) >> - return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) } + {% case unLoc $1 of + (h:t) -> do + h' <- addTrailingCommaA h (gl $2) + return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (glRR $1) (reverse (h':t)))]) } | squals ',' qual {% runPV $3 >>= \ $3 -> - addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } - | transformqual {% ams $1 (fst $ unLoc $1) >> - return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) } + case unLoc $1 of + (h:t) -> do + h' <- addTrailingCommaA h (gl $2) + return (sLL $1 (reLoc $>) ($3 : (h':t))) } + | transformqual {% return (sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])]) } | qual {% runPV $1 >>= \ $1 -> - return $ sL1 $1 [$1] } + return $ sL1A $1 [$1] } -- | transformquals1 ',' '{|' pquals '|}' { sLL $1 $> ($4 : unLoc $1) } -- | '{|' pquals '|}' { sL1 $1 [$2] } @@ -3147,24 +3147,25 @@ squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } -- In reverse order, becau -- consensus on the syntax, this feature is not being used until we -- get user demand. -transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } +transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) } -- Function is applied to a list of stmts *in order* - : 'then' exp {% runPV (unECP $2) >>= \ $2 -> return $ - sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) } + : 'then' exp {% runPV (unECP $2) >>= \ $2 -> + acs (\cs-> + sLLlA $1 $> (\r ss -> (mkTransformStmt (ApiAnn (anc r) [mj AnnThen $1] cs) ss $2))) } | 'then' exp 'by' exp {% runPV (unECP $2) >>= \ $2 -> runPV (unECP $4) >>= \ $4 -> - return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy $3], - \ss -> (mkTransformByStmt ss $2 $4)) } + acs (\cs -> sLLlA $1 $> ( + \r ss -> (mkTransformByStmt (ApiAnn (anc r) [mj AnnThen $1,mj AnnBy $3] cs) ss $2 $4))) } | 'then' 'group' 'using' exp {% runPV (unECP $4) >>= \ $4 -> - return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3], - \ss -> (mkGroupUsingStmt ss $4)) } + acs (\cs -> sLLlA $1 $> ( + \r ss -> (mkGroupUsingStmt (ApiAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] cs) ss $4))) } | 'then' 'group' 'by' exp 'using' exp {% runPV (unECP $4) >>= \ $4 -> runPV (unECP $6) >>= \ $6 -> - return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5], - \ss -> (mkGroupByUsingStmt ss $4 $6)) } + acs (\cs -> sLLlA $1 $> ( + \r ss -> (mkGroupByUsingStmt (ApiAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] cs) ss $4 $6))) } -- Note that 'group' is a special_id, which means that you can enable -- TransformListComp while still using Data.List.group. However, this @@ -3179,70 +3180,70 @@ guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] } : guardquals1 ',' qual {% runPV $3 >>= \ $3 -> - addAnnotation (gl $ head $ unLoc $1) AnnComma - (gl $2) >> - return (sLL $1 $> ($3 : unLoc $1)) } + case unLoc $1 of + (h:t) -> do + h' <- addTrailingCommaA h (gl $2) + return (sLL $1 (reLoc $>) ($3 : (h':t))) } | qual {% runPV $1 >>= \ $1 -> - return $ sL1 $1 [$1] } + return $ sL1A $1 [$1] } ----------------------------------------------------------------------------- -- Case alternatives -altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } - : '{' alts '}' { $2 >>= \ $2 -> return $ - sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) - ,(reverse (snd $ unLoc $2))) } - | vocurly alts close { $2 >>= \ $2 -> return $ - L (getLoc $2) (fst $ unLoc $2 - ,(reverse (snd $ unLoc $2))) } - | '{' '}' { return $ sLL $1 $> ([moc $1,mcc $2],[]) } - | vocurly close { return $ noLoc ([],[]) } - -alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } +altslist :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) } + : '{' alts '}' { $2 >>= \ $2 -> amsrl + (sLL $1 $> (reverse (snd $ unLoc $2))) + (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) } + | vocurly alts close { $2 >>= \ $2 -> amsrl + (L (getLoc $2) (reverse (snd $ unLoc $2))) + (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) } + | '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) } + | vocurly close { return $ noLocA [] } + +alts :: { forall b. DisambECP b => PV (Located ([AddApiAnn],[LMatch GhcPs (LocatedA b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> return $ - sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)) + sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2)) ,snd $ unLoc $2) } -alts1 :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } +alts1 :: { forall b. DisambECP b => PV (Located ([AddApiAnn],[LMatch GhcPs (LocatedA b)])) } : alts1 ';' alt { $1 >>= \ $1 -> $3 >>= \ $3 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,[$3])) - else (ams (head $ snd $ unLoc $1) - (mj AnnSemi $2:(fst $ unLoc $1)) - >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) } + case snd $ unLoc $1 of + [] -> return (sLL $1 (reLoc $>) ((mz AnnSemi $2) ++(fst $ unLoc $1) + ,[$3])) + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) } | alts1 ';' { $1 >>= \ $1 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,snd $ unLoc $1)) - else (ams (head $ snd $ unLoc $1) - (mj AnnSemi $2:(fst $ unLoc $1)) - >> return (sLL $1 $> ([],snd $ unLoc $1))) } - | alt { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) } - -alt :: { forall b. DisambECP b => PV (LMatch GhcPs (Located b)) } + case snd $ unLoc $1 of + [] -> return (sLL $1 $> ((mz AnnSemi $2) ++(fst $ unLoc $1) + ,[])) + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (sLL $1 $> (fst $ unLoc $1, h' : t)) } + | alt { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) } + +alt :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) } : pat alt_rhs { $2 >>= \ $2 -> - ams (sLL $1 $> (Match { m_ext = noExtField + acsA (\cs -> sLL (reLoc $1) $> + (Match { m_ext = (ApiAnn (glAR $1) [] cs) , m_ctxt = CaseAlt , m_pats = [$1] - , m_grhss = snd $ unLoc $2 })) - (fst $ unLoc $2)} + , m_grhss = unLoc $2 }))} -alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b))) } +alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) } : ralt wherebinds { $1 >>= \alt -> - return $ sLL alt $> (fst $ unLoc $2, GRHSs noExtField (unLoc alt) (snd $ unLoc $2)) } + return $ sLL alt (adaptWhereBinds $>) (GRHSs noExtField (unLoc alt) (unLoc $ adaptWhereBinds $2)) } -ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } +ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) } : '->' exp { unECP $2 >>= \ $2 -> - ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2)) - [mu AnnRarrow $1] } + acs (\cs -> sLLlA $1 $> (unguardedRHS (ApiAnn (glR $1) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) } | gdpats { $1 >>= \gdpats -> return $ sL1 gdpats (reverse (unLoc gdpats)) } -gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } +gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) } : gdpats gdpat { $1 >>= \gdpats -> $2 >>= \gdpat -> return $ sLL gdpats gdpat (gdpat : unLoc gdpats) } @@ -3251,17 +3252,16 @@ gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) } -- layout for MultiWayIf doesn't begin with an open brace, because it's hard to -- generate the open brace in addition to the vertical bar in the lexer, and -- we don't need it. -ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } +ifgdpats :: { Located ([AddApiAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } : '{' gdpats '}' {% runPV $2 >>= \ $2 -> return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2) } | gdpats close {% runPV $1 >>= \ $1 -> return $ sL1 $1 ([],unLoc $1) } -gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) } +gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) } : '|' guardquals '->' exp { unECP $4 >>= \ $4 -> - ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4) - [mj AnnVbar $1,mu AnnRarrow $3] } + acs (\cs -> sL (comb2A $1 $>) $ GRHS (ApiAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) } -- 'pat' recognises a pattern, including one with a bang at the top -- e.g. "!x" or "!(x,y)" or "C a b" etc @@ -3285,13 +3285,11 @@ apats :: { [LPat GhcPs] } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } - : '{' stmts '}' { $2 >>= \ $2 -> return $ - sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2)) - ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse? - | vocurly stmts close { $2 >>= \ $2 -> return $ - L (gl $2) (fst $ unLoc $2 - ,reverse $ snd $ unLoc $2) } +stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) } + : '{' stmts '}' { $2 >>= \ $2 -> amsrl + (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)) } -- AZ:performance of reverse? + | vocurly stmts close { $2 >>= \ $2 -> amsrl + (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)) } -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3299,26 +3297,24 @@ stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Locat -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead -stmts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) } +stmts :: { forall b. DisambECP b => PV (Located ([TrailingAnn],[LStmt GhcPs (LocatedA b)])) } : stmts ';' stmt { $1 >>= \ $1 -> - $3 >>= \ $3 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1) - ,$3 : (snd $ unLoc $1))) - else do - { ams (head $ snd $ unLoc $1) [mj AnnSemi $2] - ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }} + $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) -> + case (snd $ unLoc $1) of + [] -> return (sLL $1 (reLoc $>) ((msemi $2) ++ (fst $ unLoc $1) + ,$3 : (snd $ unLoc $1))) + (h:t) -> do + { h' <- addTrailingSemiA h (gl $2) + ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(h':t)) }} | stmts ';' { $1 >>= \ $1 -> - if null (snd $ unLoc $1) - then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1)) - else do - { ams (head $ snd $ unLoc $1) - [mj AnnSemi $2] - ; return $1 } - } + case (snd $ unLoc $1) of + [] -> return (sLL $1 $> ((msemi $2) ++ (fst $ unLoc $1),snd $ unLoc $1)) + (h:t) -> do + { h' <- addTrailingSemiA h (gl $2) + ; return $ sL1 $1 (fst $ unLoc $1,h':t) }} | stmt { $1 >>= \ $1 -> - return $ sL1 $1 ([],[$1]) } + return $ sL1A $1 ([],[$1]) } | {- empty -} { return $ noLoc ([],[]) } @@ -3332,100 +3328,110 @@ maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) } e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } : stmt {% runPV $1 } -stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } +stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> - ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2)) - (mj AnnRec $1:(fst $ unLoc $2)) } + acsA (\cs -> (sLL $1 (reLoc $>) $ mkRecStmt + (ApiAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs) + $2)) } -qual :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } +qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : bindpat '<-' exp { unECP $3 >>= \ $3 -> - ams (sLL $1 $> $ mkPsBindStmt $1 $3) - [mu AnnLarrow $2] } + acsA (\cs -> sLLlA (reLoc $1) $> + $ mkPsBindStmt (ApiAnn (glAR $1) [mu AnnLarrow $2] cs) $1 $3) } | exp { unECP $1 >>= \ $1 -> return $ sL1 $1 $ mkBodyStmt $1 } - | 'let' binds { ams (sLL $1 $> $ LetStmt noExtField (snd $ unLoc $2)) - (mj AnnLet $1:(fst $ unLoc $2)) } + | 'let' binds { acsA (\cs -> (sLL $1 $> + $ mkLetStmt (ApiAnn (glR $1) [mj AnnLet $1] cs) (unLoc $2))) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) } +fbinds :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) } : fbinds1 { $1 } - | {- empty -} { return ([],([], Nothing)) } + | {- empty -} { return ([], Nothing) } -fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([Fbind b], Maybe SrcSpan)) } +fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) } : fbind ',' fbinds1 { $1 >>= \ $1 -> - $3 >>= \ $3 -> - let gl' = \case { Left (L l _) -> l; Right (L l _) -> l } in - addAnnotation (gl' $1) AnnComma (gl $2) >> - return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) } + $3 >>= \ $3 -> do + h <- addTrailingCommaFBind $1 (gl $2) + return (case $3 of (flds, dd) -> (h : flds, dd)) } | fbind { $1 >>= \ $1 -> - return ([],([$1], Nothing)) } - | '..' { return ([mj AnnDotdot $1],([], Just (getLoc $1))) } + return ([$1], Nothing) } + | '..' { return ([], Just (getLoc $1)) } fbind :: { forall b. DisambECP b => PV (Fbind b) } : qvar '=' texp { unECP $3 >>= \ $3 -> - fmap Left $ ams (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False) [mj AnnEqual $2] - } + fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsRecField (ApiAnn (glNR $1) [mj AnnEqual $2] cs) (sL1N $1 $ mkFieldOcc $1) $3 False) } -- RHS is a 'texp', allowing view patterns (#6038) -- and, incidentally, sections. Eg -- f (R { x = show -> s }) = ... | qvar { placeHolderPunRhs >>= \rhs -> - fmap Left $ return (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True) - } + fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsRecField (ApiAnn (glNR $1) [] cs) (sL1N $1 $ mkFieldOcc $1) rhs True) } -- In the punning case, use a place-holder -- The renamer fills in the final value -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + -- AZ: need to pull out the let block into a helper | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp { do - let top = $1 - fields = top : reverse $3 + let top = sL1 $1 $ HsFieldLabel noAnn $1 + ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3) + lf' = comb2 $2 (L lf ()) + fields = top : L lf' (HsFieldLabel (ApiAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t final = last fields - l = comb2 top final + l = comb2 $1 $3 isPun = False $5 <- unECP $5 - fmap Right $ mkHsProjUpdatePV (comb2 $1 $5) (L l fields) $5 isPun + fmap Right $ mkHsProjUpdatePV (comb2 $1 (reLoc $5)) (L l fields) $5 isPun + [mj AnnEqual $4] } -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer + -- AZ: need to pull out the let block into a helper | field TIGHT_INFIX_PROJ fieldToUpdate { do - let top = $1 - fields = top : reverse $3 + let top = sL1 $1 $ HsFieldLabel noAnn $1 + ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3) + lf' = comb2 $2 (L lf ()) + fields = top : L lf' (HsFieldLabel (ApiAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t final = last fields - l = comb2 top final + l = comb2 $1 $3 isPun = True - var <- mkHsVarPV (noLoc (mkRdrUnqual . mkVarOcc . unpackFS . unLoc $ final)) - fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun + var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . hflLabel . unLoc $ final)) + fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun [] } -fieldToUpdate :: { [Located FastString] } +fieldToUpdate :: { Located [Located (HsFieldLabel GhcPs)] } fieldToUpdate -- See Note [Whitespace-sensitive operator parsing] in Lexer.x - : fieldToUpdate TIGHT_INFIX_PROJ field { $3 : $1 } - | field { [$1] } + : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLoc $3) >>= \cs -> + return (sLL $1 $> ((sLL $2 $> (HsFieldLabel (ApiAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) } + | field {% getCommentsFor (getLoc $1) >>= \cs -> + return (sL1 $1 [sL1 $1 (HsFieldLabel (ApiAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) } ----------------------------------------------------------------------------- -- Implicit Parameter Bindings -dbinds :: { Located [LIPBind GhcPs] } +dbinds :: { Located [LIPBind GhcPs] } -- reversed : dbinds ';' dbind - {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> - return (let { this = $3; rest = unLoc $1 } - in rest `seq` this `seq` sLL $1 $> (this : rest)) } - | dbinds ';' {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >> - return (sLL $1 $> (unLoc $1)) } - | dbind { let this = $1 in this `seq` sL1 $1 [this] } + {% case unLoc $1 of + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (let { this = $3; rest = h':t } + in rest `seq` this `seq` sLL $1 (reLoc $>) (this : rest)) } + | dbinds ';' {% case unLoc $1 of + (h:t) -> do + h' <- addTrailingSemiA h (gl $2) + return (sLL $1 $> (h':t)) } + | dbind { let this = $1 in this `seq` (sL1 (reLoc $1) [this]) } -- | {- empty -} { [] } dbind :: { LIPBind GhcPs } dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 -> - ams (sLL $1 $> (IPBind noExtField (Left $1) $3)) - [mj AnnEqual $2] } + acsA (\cs -> sLLlA $1 $> (IPBind (ApiAnn (glR $1) [mj AnnEqual $2] cs) (Left $1) $3)) } ipvar :: { Located HsIPName } : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } @@ -3439,35 +3445,37 @@ overloaded_label :: { Located FastString } ----------------------------------------------------------------------------- -- Warnings and deprecations -name_boolformula_opt :: { LBooleanFormula (Located RdrName) } +name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) } : name_boolformula { $1 } - | {- empty -} { noLoc mkTrue } + | {- empty -} { noLocA mkTrue } -name_boolformula :: { LBooleanFormula (Located RdrName) } +name_boolformula :: { LBooleanFormula (LocatedN RdrName) } : name_boolformula_and { $1 } | name_boolformula_and '|' name_boolformula - {% aa $1 (AnnVbar, $2) - >> return (sLL $1 $> (Or [$1,$3])) } + {% do { h <- addTrailingVbarL $1 (gl $2) + ; return (reLocA $ sLLAA $1 $> (Or [h,$3])) } } -name_boolformula_and :: { LBooleanFormula (Located RdrName) } +name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) } : name_boolformula_and_list - { sLL (head $1) (last $1) (And ($1)) } + { reLocA $ sLLAA (head $1) (last $1) (And ($1)) } -name_boolformula_and_list :: { [LBooleanFormula (Located RdrName)] } +name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] } : name_boolformula_atom { [$1] } | name_boolformula_atom ',' name_boolformula_and_list - {% aa $1 (AnnComma, $2) >> return ($1 : $3) } + {% do { h <- addTrailingCommaL $1 (gl $2) + ; return (h : $3) } } -name_boolformula_atom :: { LBooleanFormula (Located RdrName) } - : '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] } - | name_var { sL1 $1 (Var $1) } +name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) } + : '(' name_boolformula ')' {% amsrl (sLL $1 $> (Parens $2)) + (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) } + | name_var { reLocA $ sL1N $1 (Var $1) } -namelist :: { Located [Located RdrName] } -namelist : name_var { sL1 $1 [$1] } - | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> ($1 : unLoc $3)) } +namelist :: { Located [LocatedN RdrName] } +namelist : name_var { sL1N $1 [$1] } + | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2) + ; return (sLL (reLocN $1) $> (h : unLoc $3)) }} -name_var :: { Located RdrName } +name_var :: { LocatedN RdrName } name_var : var { $1 } | con { $1 } @@ -3476,55 +3484,53 @@ name_var : var { $1 } -- There are two different productions here as lifted list constructors -- are parsed differently. -qcon_nowiredlist :: { Located RdrName } +qcon_nowiredlist :: { LocatedN RdrName } : gen_qcon { $1 } - | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + | sysdcon_nolist { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) } -qcon :: { Located RdrName } +qcon :: { LocatedN RdrName } : gen_qcon { $1} - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + | sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) } -gen_qcon :: { Located RdrName } +gen_qcon :: { LocatedN RdrName } : qconid { $1 } - | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } + | '(' qconsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } -con :: { Located RdrName } +con :: { LocatedN RdrName } : conid { $1 } - | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + | '(' consym ')' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } + | sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) } -con_list :: { Located [Located RdrName] } -con_list : con { sL1 $1 [$1] } - | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >> - return (sLL $1 $> ($1 : unLoc $3)) } +con_list :: { Located [LocatedN RdrName] } +con_list : con { sL1N $1 [$1] } + | con ',' con_list {% do { h <- addTrailingCommaN $1 (gl $2) + ; return (sLL (reLocN $1) $> (h : unLoc $3)) }} -- See Note [ExplicitTuple] in GHC.Hs.Expr -sysdcon_nolist :: { Located DataCon } -- Wired in data constructors - : '(' ')' {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] } - | '(' commas ')' {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) - (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' '#)' {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] } - | '(#' commas '#)' {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) - (mo $1:mc $3:(mcommas (fst $2))) } +sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors + : '(' ')' {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } + | '(' commas ')' {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) + (NameAnnCommas NameParens (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } + | '(#' '#)' {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } + | '(#' commas '#)' {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) + (NameAnnCommas NameParensHash (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } -- See Note [Empty lists] in GHC.Hs.Expr -sysdcon :: { Located DataCon } +sysdcon :: { LocatedN DataCon } : sysdcon_nolist { $1 } - | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] } + | '[' ']' {% amsrn (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) } -conop :: { Located RdrName } +conop :: { LocatedN RdrName } : consym { $1 } - | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } + | '`' conid '`' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) } -qconop :: { Located RdrName } +qconop :: { LocatedN RdrName } : qconsym { $1 } - | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } + | '`' qconid '`' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) } ---------------------------------------------------------------------------- -- Type constructors @@ -3532,44 +3538,45 @@ qconop :: { Located RdrName } -- See Note [Unit tuples] in GHC.Hs.Type for the distinction -- between gtycon and ntgtycon -gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples +gtycon :: { LocatedN RdrName } -- A "general" qualified tycon, including unit tuples : ntgtycon { $1 } - | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) - [mop $1,mcp $2] } - | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) - [mo $1,mc $2] } + | '(' ')' {% amsrn (sLL $1 $> $ getRdrName unitTyCon) + (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } + | '(#' '#)' {% amsrn (sLL $1 $> $ getRdrName unboxedUnitTyCon) + (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } -ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples +ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit tuples : oqtycon { $1 } - | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed + | '(' commas ')' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed (snd $2 + 1))) - (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed + (NameAnnCommas NameParens (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } + | '(#' commas '#)' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed (snd $2 + 1))) - (mo $1:mc $3:(mcommas (fst $2))) } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon) - [mop $1,mu AnnRarrow $2,mcp $3] } - | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } + (NameAnnCommas NameParensHash (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } + | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) + (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } + | '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR) + (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) } -oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; +oqtycon :: { LocatedN RdrName } -- An "ordinary" qualified tycon; -- These can appear in export lists : qtycon { $1 } - | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } + | '(' qtyconsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } -oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mistaken +oqtycon_no_varcon :: { LocatedN RdrName } -- Type constructor which cannot be mistaken -- for variable constructor in export lists -- see Note [Type constructors in export list] : qtycon { $1 } | '(' QCONSYM ')' {% let { name :: Located RdrName ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) } - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } | '(' CONSYM ')' {% let { name :: Located RdrName ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) } - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } | '(' ':' ')' {% let { name :: Located RdrName ; name = sL1 $2 $! consDataCon_RDR } - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } {- Note [Type constructors in export list] ~~~~~~~~~~~~~~~~~~~~~ @@ -3591,101 +3598,95 @@ until after renaming when we resolve the proper namespace for each exported child. -} -qtyconop :: { Located RdrName } -- Qualified or unqualified +qtyconop :: { LocatedN RdrName } -- Qualified or unqualified -- See Note [%shift: qtyconop -> qtyconsym] : qtyconsym %shift { $1 } - | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } + | '`' qtycon '`' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) } -qtycon :: { Located RdrName } -- Qualified or unqualified - : QCONID { sL1 $1 $! mkQual tcClsName (getQCONID $1) } +qtycon :: { LocatedN RdrName } -- Qualified or unqualified + : QCONID { sL1n $1 $! mkQual tcClsName (getQCONID $1) } | tycon { $1 } -tycon :: { Located RdrName } -- Unqualified - : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } +tycon :: { LocatedN RdrName } -- Unqualified + : CONID { sL1n $1 $! mkUnqual tcClsName (getCONID $1) } -qtyconsym :: { Located RdrName } - : QCONSYM { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) } - | QVARSYM { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) } +qtyconsym :: { LocatedN RdrName } + : QCONSYM { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) } + | QVARSYM { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) } | tyconsym { $1 } -tyconsym :: { Located RdrName } - : CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) } - | VARSYM { sL1 $1 $! +tyconsym :: { LocatedN RdrName } + : CONSYM { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) } + | VARSYM { sL1n $1 $! -- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types if getVARSYM $1 == fsLit "~" then eqTyCon_RDR else mkUnqual tcClsName (getVARSYM $1) } - | ':' { sL1 $1 $! consDataCon_RDR } - | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } - | '.' { sL1 $1 $! mkUnqual tcClsName (fsLit ".") } + | ':' { sL1n $1 $! consDataCon_RDR } + | '-' { sL1n $1 $! mkUnqual tcClsName (fsLit "-") } + | '.' { sL1n $1 $! mkUnqual tcClsName (fsLit ".") } -- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version. -- These can appear in `ANN type` declarations (#19374). -otycon :: { Located RdrName } +otycon :: { LocatedN RdrName } : tycon { $1 } - | '(' tyconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } + | '(' tyconsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } ----------------------------------------------------------------------------- -- Operators -op :: { Located RdrName } -- used in infix decls +op :: { LocatedN RdrName } -- used in infix decls : varop { $1 } | conop { $1 } - | '->' { sL1 $1 $ getRdrName unrestrictedFunTyCon } + | '->' { sL1n $1 $ getRdrName unrestrictedFunTyCon } -varop :: { Located RdrName } +varop :: { LocatedN RdrName } : varsym { $1 } - | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } + | '`' varid '`' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) } -qop :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections +qop :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections : qvarop { mkHsVarOpPV $1 } | qconop { mkHsConOpPV $1 } - | hole_op { $1 } + | hole_op { pvN $1 } -qopm :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections +qopm :: { forall b. DisambInfixOp b => PV (LocatedN b) } -- used in sections : qvaropm { mkHsVarOpPV $1 } | qconop { mkHsConOpPV $1 } - | hole_op { $1 } + | hole_op { pvN $1 } hole_op :: { forall b. DisambInfixOp b => PV (Located b) } -- used in sections -hole_op : '`' '_' '`' { amms (mkHsInfixHolePV (comb2 $1 $>)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } +hole_op : '`' '_' '`' { mkHsInfixHolePV (comb2 $1 $>) + (\cs -> ApiAnn (glR $1) (ApiAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) } -qvarop :: { Located RdrName } +qvarop :: { LocatedN RdrName } : qvarsym { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } + | '`' qvarid '`' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) } -qvaropm :: { Located RdrName } +qvaropm :: { LocatedN RdrName } : qvarsym_no_minus { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } + | '`' qvarid '`' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) } ----------------------------------------------------------------------------- -- Type variables -tyvar :: { Located RdrName } +tyvar :: { LocatedN RdrName } tyvar : tyvarid { $1 } -tyvarop :: { Located RdrName } -tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 - ,mj AnnBackquote $3] } - -tyvarid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual tvName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual tvName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual tvName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") } +tyvarop :: { LocatedN RdrName } +tyvarop : '`' tyvarid '`' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) } + +tyvarid :: { LocatedN RdrName } + : VARID { sL1n $1 $! mkUnqual tvName (getVARID $1) } + | special_id { sL1n $1 $! mkUnqual tvName (unLoc $1) } + | 'unsafe' { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") } + | 'safe' { sL1n $1 $! mkUnqual tvName (fsLit "safe") } + | 'interruptible' { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") } -- If this changes relative to varid, update 'checkRuleTyVarBndrNames' -- in GHC.Parser.PostProcess -- See Note [Parsing explicit foralls in Rules] @@ -3693,17 +3694,17 @@ tyvarid :: { Located RdrName } ----------------------------------------------------------------------------- -- Variables -var :: { Located RdrName } +var :: { LocatedN RdrName } : varid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } + | '(' varsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } -qvar :: { Located RdrName } +qvar :: { LocatedN RdrName } : qvarid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } + | '(' varsym ')' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } + | '(' qvarsym1 ')' {% amsrn (sLL $1 $> (unLoc $2)) + (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } -- We've inlined qvarsym here so that the decision about -- whether it's a qvar or a var can be postponed until -- *after* we see the close paren. @@ -3711,45 +3712,45 @@ qvar :: { Located RdrName } field :: { Located FastString } : VARID { sL1 $1 $! getVARID $1 } -qvarid :: { Located RdrName } +qvarid :: { LocatedN RdrName } : varid { $1 } - | QVARID { sL1 $1 $! mkQual varName (getQVARID $1) } + | QVARID { sL1n $1 $! mkQual varName (getQVARID $1) } -- Note that 'role' and 'family' get lexed separately regardless of -- the use of extensions. However, because they are listed here, -- this is OK and they can be used as normal varids. -- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer -varid :: { Located RdrName } - : VARID { sL1 $1 $! mkUnqual varName (getVARID $1) } - | special_id { sL1 $1 $! mkUnqual varName (unLoc $1) } - | 'unsafe' { sL1 $1 $! mkUnqual varName (fsLit "unsafe") } - | 'safe' { sL1 $1 $! mkUnqual varName (fsLit "safe") } - | 'interruptible' { sL1 $1 $! mkUnqual varName (fsLit "interruptible")} - | 'forall' { sL1 $1 $! mkUnqual varName (fsLit "forall") } - | 'family' { sL1 $1 $! mkUnqual varName (fsLit "family") } - | 'role' { sL1 $1 $! mkUnqual varName (fsLit "role") } +varid :: { LocatedN RdrName } + : VARID { sL1n $1 $! mkUnqual varName (getVARID $1) } + | special_id { sL1n $1 $! mkUnqual varName (unLoc $1) } + | 'unsafe' { sL1n $1 $! mkUnqual varName (fsLit "unsafe") } + | 'safe' { sL1n $1 $! mkUnqual varName (fsLit "safe") } + | 'interruptible' { sL1n $1 $! mkUnqual varName (fsLit "interruptible")} + | 'forall' { sL1n $1 $! mkUnqual varName (fsLit "forall") } + | 'family' { sL1n $1 $! mkUnqual varName (fsLit "family") } + | 'role' { sL1n $1 $! mkUnqual varName (fsLit "role") } -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames' -- in GHC.Parser.PostProcess -- See Note [Parsing explicit foralls in Rules] -qvarsym :: { Located RdrName } +qvarsym :: { LocatedN RdrName } : varsym { $1 } | qvarsym1 { $1 } -qvarsym_no_minus :: { Located RdrName } +qvarsym_no_minus :: { LocatedN RdrName } : varsym_no_minus { $1 } | qvarsym1 { $1 } -qvarsym1 :: { Located RdrName } -qvarsym1 : QVARSYM { sL1 $1 $ mkQual varName (getQVARSYM $1) } +qvarsym1 :: { LocatedN RdrName } +qvarsym1 : QVARSYM { sL1n $1 $ mkQual varName (getQVARSYM $1) } -varsym :: { Located RdrName } +varsym :: { LocatedN RdrName } : varsym_no_minus { $1 } - | '-' { sL1 $1 $ mkUnqual varName (fsLit "-") } + | '-' { sL1n $1 $ mkUnqual varName (fsLit "-") } -varsym_no_minus :: { Located RdrName } -- varsym not including '-' - : VARSYM { sL1 $1 $ mkUnqual varName (getVARSYM $1) } - | special_sym { sL1 $1 $ mkUnqual varName (unLoc $1) } +varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-' + : VARSYM { sL1n $1 $ mkUnqual varName (getVARSYM $1) } + | special_sym { sL1n $1 $ mkUnqual varName (unLoc $1) } -- These special_ids are treated as keywords in various places, @@ -3785,22 +3786,22 @@ special_sym : '.' { sL1 $1 (fsLit ".") } ----------------------------------------------------------------------------- -- Data constructors -qconid :: { Located RdrName } -- Qualified or unqualified +qconid :: { LocatedN RdrName } -- Qualified or unqualified : conid { $1 } - | QCONID { sL1 $1 $! mkQual dataName (getQCONID $1) } + | QCONID { sL1n $1 $! mkQual dataName (getQCONID $1) } -conid :: { Located RdrName } - : CONID { sL1 $1 $ mkUnqual dataName (getCONID $1) } +conid :: { LocatedN RdrName } + : CONID { sL1n $1 $ mkUnqual dataName (getCONID $1) } -qconsym :: { Located RdrName } -- Qualified or unqualified +qconsym :: { LocatedN RdrName } -- Qualified or unqualified : consym { $1 } - | QCONSYM { sL1 $1 $ mkQual dataName (getQCONSYM $1) } + | QCONSYM { sL1n $1 $ mkQual dataName (getQCONSYM $1) } -consym :: { Located RdrName } - : CONSYM { sL1 $1 $ mkUnqual dataName (getCONSYM $1) } +consym :: { LocatedN RdrName } + : CONSYM { sL1n $1 $ mkUnqual dataName (getCONSYM $1) } -- ':' means only list cons - | ':' { sL1 $1 $ consDataCon_RDR } + | ':' { sL1n $1 $ consDataCon_RDR } ----------------------------------------------------------------------------- @@ -3843,13 +3844,13 @@ commas :: { ([SrcSpan],Int) } -- One or more commas : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) } | ',' { ([gl $1],1) } -bars0 :: { ([SrcSpan],Int) } -- Zero or more bars +bars0 :: { ([AnnAnchor],Int) } -- Zero or more bars : bars { $1 } | { ([], 0) } -bars :: { ([SrcSpan],Int) } -- One or more bars - : bars '|' { ((fst $1)++[gl $2],snd $1 + 1) } - | '|' { ([gl $1],1) } +bars :: { ([AnnAnchor],Int) } -- One or more bars + : bars '|' { ((fst $1)++[glAA $2],snd $1 + 1) } + | '|' { ([glAA $1],1) } { happyError :: P a @@ -3910,7 +3911,7 @@ getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src getCTYPEs (L _ (ITctype src)) = src -getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) +getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing isUnicode :: Located Token -> Bool isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax @@ -3946,10 +3947,28 @@ getSCC lt = do let s = getSTRING lt comb2 :: Located a -> Located b -> SrcSpan comb2 a b = a `seq` b `seq` combineLocs a b +-- Utilities for combining source spans +comb2A :: Located a -> LocatedAn t b -> SrcSpan +comb2A a b = a `seq` b `seq` combineLocs a (reLoc b) + +comb2N :: Located a -> LocatedN b -> SrcSpan +comb2N a b = a `seq` b `seq` combineLocs a (reLocN b) + +comb2Al :: LocatedAn t a -> Located b -> SrcSpan +comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b + comb3 :: Located a -> Located b -> Located c -> SrcSpan comb3 a b c = a `seq` b `seq` c `seq` combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) +comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan +comb3A a b c = a `seq` b `seq` c `seq` + combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c)) + +comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan +comb3N a b c = a `seq` b `seq` c `seq` + combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c)) + comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan comb4 a b c d = a `seq` b `seq` c `seq` d `seq` (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ @@ -3962,8 +3981,8 @@ comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq` -- strict constructor version: {-# INLINE sL #-} -sL :: SrcSpan -> a -> Located a -sL span a = span `seq` a `seq` L span a +sL :: l -> a -> GenLocated l a +sL loc a = loc `seq` a `seq` L loc a -- See Note [Adding location info] for how these utility functions are used @@ -3973,13 +3992,46 @@ sL0 :: a -> Located a sL0 = L noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} -sL1 :: Located a -> b -> Located b +sL1 :: GenLocated l a -> b -> GenLocated l b sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) +{-# INLINE sL1A #-} +sL1A :: LocatedAn t a -> b -> Located b +sL1A x = sL (getLocA x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sL1N #-} +sL1N :: LocatedN a -> b -> Located b +sL1N x = sL (getLocA x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sL1a #-} +sL1a :: Located a -> b -> LocatedAn t b +sL1a x = sL (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sL1n #-} +sL1n :: Located a -> b -> LocatedN b +sL1n x = L (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1) + {-# INLINE sLL #-} sLL :: Located a -> Located b -> c -> Located c sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) +{-# INLINE sLLa #-} +sLLa :: Located a -> Located b -> c -> LocatedAn t c +sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLlA #-} +sLLlA :: Located a -> LocatedAn t b -> c -> Located c +sLLlA x y = sL (comb2A x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLAl #-} +sLLAl :: LocatedAn t a -> Located b -> c -> Located c +sLLAl x y = sL (comb2A y x) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLAA #-} +sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c +sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL sL (comb2 $1 $>) + + {- Note [Adding location info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4032,13 +4084,13 @@ hintLinear span = do unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span -- Does this look like (a %m)? -looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool +looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool looksLikeMult ty1 l_op ty2 | Unqual op_name <- unLoc l_op , occNameFS op_name == fsLit "%" - , Just ty1_pos <- getBufSpan (getLoc ty1) - , Just pct_pos <- getBufSpan (getLoc l_op) - , Just ty2_pos <- getBufSpan (getLoc ty2) + , Just ty1_pos <- getBufSpan (getLocA ty1) + , Just pct_pos <- getBufSpan (getLocA l_op) + , Just ty2_pos <- getBufSpan (getLocA ty2) , bufSpanEnd ty1_pos /= bufSpanStart pct_pos , bufSpanEnd pct_pos == bufSpanStart ty2_pos = True @@ -4091,17 +4143,31 @@ in GHC.Parser.Annotation -} --- |Construct an AddAnn from the annotation keyword and the location +-- |Construct an AddApiAnn from the annotation keyword and the location -- of the keyword itself -mj :: AnnKeywordId -> Located e -> AddAnn -mj a l = AddAnn a (gl l) +mj :: AnnKeywordId -> Located e -> AddApiAnn +mj a l = AddApiAnn a (AR $ rs $ gl l) + +mjN :: AnnKeywordId -> LocatedN e -> AddApiAnn +mjN a l = AddApiAnn a (AR $ rs $ glN l) + +-- |Construct an AddApiAnn from the annotation keyword and the location +-- of the keyword itself, provided the span is not zero width +mz :: AnnKeywordId -> Located e -> [AddApiAnn] +mz a l = if isZeroWidthSpan (gl l) then [] else [AddApiAnn a (AR $ rs $ gl l)] +msemi :: Located e -> [TrailingAnn] +msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (AR $ rs $ gl l)] --- |Construct an AddAnn from the annotation keyword and the Located Token. If +-- |Construct an AddApiAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. -mu :: AnnKeywordId -> Located Token -> AddAnn -mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l +mu :: AnnKeywordId -> Located Token -> AddApiAnn +mu a lt@(L l t) = AddApiAnn (toUnicodeAnn a lt) (AR $ rs l) + +mau :: Located Token -> TrailingAnn +mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (AR $ rs l) + else AddRarrowAnn (AR $ rs l) -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation @@ -4111,94 +4177,125 @@ toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a toUnicode :: Located Token -> IsUnicodeSyntax toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax -gl :: Located a -> SrcSpan +gl :: GenLocated l a -> l gl = getLoc --- |Add an annotation to the located element, and return the located --- element as a pass through -aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a) -aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a - --- |Add an annotation to a located element resulting from a monadic action -am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a) -am a (b,s) = do - av@(L l _) <- a - addAnnotation l b (gl s) - return av - --- | Add a list of AddAnns to the given AST element. For example, --- the parsing rule for @let@ looks like: --- --- @ --- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) --- (mj AnnLet $1:mj AnnIn $3 --- :(fst $ unLoc $2)) } --- @ --- --- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well --- as any annotations that may arise in the binds. This will include open --- and closing braces if they are used to delimit the let expressions. --- -ams :: MonadP m => Located a -> [AddAnn] -> m (Located a) -ams a@(L l _) bs = addAnnsAt l bs >> return a - -amsL :: SrcSpan -> [AddAnn] -> P () -amsL sp bs = addAnnsAt sp bs >> return () - --- |Add all [AddAnn] to an AST element, and wrap it in a 'Just' -ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a)) -ajs a bs = Just <$> ams a bs - --- |Add a list of AddAnns to the given AST element, where the AST element is the --- result of a monadic action -amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a) -amms a bs = do { av@(L l _) <- a - ; addAnnsAt l bs - ; return av } - --- |Add a list of AddAnns to the AST element, and return the element as a --- OrdList -amsu :: Located a -> [AddAnn] -> P (OrdList (Located a)) -amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a) - --- |Synonyms for AddAnn versions of AnnOpen and AnnClose -mo,mc :: Located Token -> AddAnn +glA :: LocatedAn t a -> SrcSpan +glA = getLocA + +glN :: LocatedN a -> SrcSpan +glN = getLocA + +glR :: Located a -> Anchor +glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor + +glAA :: Located a -> AnnAnchor +glAA = AR <$> realSrcSpan . getLoc + +glRR :: Located a -> RealSrcSpan +glRR = realSrcSpan . getLoc + +glAR :: LocatedAn t a -> Anchor +glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor + +glNR :: LocatedN a -> Anchor +glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor + +glNRR :: LocatedN a -> AnnAnchor +glNRR = AR <$> realSrcSpan . getLocA + +anc :: RealSrcSpan -> Anchor +anc r = Anchor r UnchangedAnchor + +acs :: MonadP m => (ApiAnnComments -> Located a) -> m (Located a) +acs a = do + let (L l _) = a noCom + cs <- getCommentsFor l + return (a cs) + +-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet. +acsFinal :: (ApiAnnComments -> Located a) -> P (Located a) +acsFinal a = do + let (L l _) = a noCom + cs <- getCommentsFor l + csf <- getFinalCommentsFor l + meof <- getEofPos + let ce = case meof of + Nothing -> AnnComments [] + Just (pos, gap) -> AnnCommentsBalanced [] [L (realSpanAsAnchor pos) (AnnComment AnnEofComment gap)] + return (a (cs Semi.<> csf Semi.<> ce)) + +acsa :: MonadP m => (ApiAnnComments -> LocatedAn t a) -> m (LocatedAn t a) +acsa a = do + let (L l _) = a noCom + cs <- getCommentsFor (locA l) + return (a cs) + +acsA :: MonadP m => (ApiAnnComments -> Located a) -> m (LocatedAn t a) +acsA a = reLocA <$> acs a + +acsExpr :: (ApiAnnComments -> LHsExpr GhcPs) -> P ECP +acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a + ; return (ecpFromExp $ expr) } + +amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) +amsA (L l a) bs = do + cs <- getCommentsFor (locA l) + return (L (addAnnsA l bs cs) a) + +amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a) +amsrc a@(L l _) bs = do + cs <- getCommentsFor l + return (reAnnC bs cs a) + +amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a) +amsrl a@(L l _) bs = do + cs <- getCommentsFor l + return (reAnnL bs cs a) + +amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a) +amsrp a@(L l _) bs = do + cs <- getCommentsFor l + return (reAnnL bs cs a) + +amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a) +amsrn (L l a) an = do + cs <- getCommentsFor l + let ann = (ApiAnn (spanAsAnchor l) an cs) + return (L (SrcSpanAnn ann l) a) + +-- |Synonyms for AddApiAnn versions of AnnOpen and AnnClose +mo,mc :: Located Token -> AddApiAnn mo ll = mj AnnOpen ll mc ll = mj AnnClose ll -moc,mcc :: Located Token -> AddAnn +moc,mcc :: Located Token -> AddApiAnn moc ll = mj AnnOpenC ll mcc ll = mj AnnCloseC ll -mop,mcp :: Located Token -> AddAnn +mop,mcp :: Located Token -> AddApiAnn mop ll = mj AnnOpenP ll mcp ll = mj AnnCloseP ll -mos,mcs :: Located Token -> AddAnn +moh,mch :: Located Token -> AddApiAnn +moh ll = mj AnnOpenPH ll +mch ll = mj AnnClosePH ll + +mos,mcs :: Located Token -> AddApiAnn mos ll = mj AnnOpenS ll mcs ll = mj AnnCloseS ll --- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma --- entry for each SrcSpan -mcommas :: [SrcSpan] -> [AddAnn] -mcommas = map (AddAnn AnnCommaTuple) - --- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar --- entry for each SrcSpan -mvbars :: [SrcSpan] -> [AddAnn] -mvbars = map (AddAnn AnnVbar) +pvA :: MonadP m => m (Located a) -> m (LocatedAn t a) +pvA a = do { av <- a + ; return (reLocA av) } --- |Get the location of the last element of a OrdList, or noSrcSpan -oll :: OrdList (Located a) -> SrcSpan -oll l = - if isNilOL l then noSrcSpan - else getLoc (lastOL l) +pvN :: MonadP m => m (Located a) -> m (LocatedN a) +pvN a = do { (L l av) <- a + ; return (L (noAnnSrcSpan l) av) } --- |Add a semicolon annotation in the right place in a list. If the --- leading list is empty, add it to the tail -asl :: [Located a] -> Located b -> Located a -> P () -asl [] (L ls _) (L l _) = addAnnotation l AnnSemi ls -asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls +pvL :: MonadP m => m (LocatedAn t a) -> m (Located a) +pvL a = do { av <- a + ; return (reLoc av) } -- | Parse a Haskell module with Haddock comments. -- This is done in two steps: @@ -4211,4 +4308,105 @@ asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls -- not insert them into the AST. parseModule :: P (Located HsModule) parseModule = parseModuleNoHaddock >>= addHaddockToModule + +commentsA :: (Monoid ann) => SrcSpan -> ApiAnnComments -> SrcSpanAnn' (ApiAnn' ann) +commentsA loc cs = SrcSpanAnn (ApiAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc + +-- | Instead of getting the *enclosed* comments, this includes the +-- *preceding* ones. It is used at the top level to get comments +-- between top level declarations. +commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a) +commentsPA la@(L l a) = do + cs <- getPriorCommentsFor (getLocA la) + return (L (addCommentsToSrcAnn l cs) a) + +rs :: SrcSpan -> RealSrcSpan +rs (RealSrcSpan l _) = l +rs _ = panic "Parser should only have RealSrcSpan" + +hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList +hsDoAnn (L l _) (L ll _) kw + = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddApiAnn kw (AR $ rs l)] [] + +listAsAnchor :: [LocatedAn t a] -> Anchor +listAsAnchor [] = spanAsAnchor noSrcSpan +listAsAnchor (L l _:_) = spanAsAnchor (locA l) + +-- ------------------------------------- + +addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b) +addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l) +addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l) + +addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a) +addTrailingVbarA la span = addTrailingAnnA la span AddVbarAnn + +addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a) +addTrailingSemiA la span = addTrailingAnnA la span AddSemiAnn + +addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a) +addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn + +addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (AnnAnchor -> TrailingAnn) -> m (LocatedA a) +addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do + -- cs <- getCommentsFor l + let cs = noCom + -- AZ:TODO: generalise updating comments into an annotation + let + anns' = if isZeroWidthSpan ss + then anns + else addTrailingAnnToA l (ta (AR $ rs ss)) cs anns + return (L (SrcSpanAnn anns' l) a) + +-- ------------------------------------- + +addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) +addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (AR $ rs span)) + +addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) +addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (AR $ rs span)) + +addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a) +addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do + cs <- getCommentsFor l + let anns' = addTrailingAnnToL l ta cs anns + return (L (SrcSpanAnn anns' l) a) + +-- ------------------------------------- + +-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation +addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a) +addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do + -- cs <- getCommentsFor l + let cs = noCom + -- AZ:TODO: generalise updating comments into an annotation + let anns' = if isZeroWidthSpan span + then anns + else addTrailingCommaToN l anns (AR $ rs span) + return (L (SrcSpanAnn anns' l) a) + +addTrailingCommaS :: Located StringLiteral -> AnnAnchor -> Located StringLiteral +addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (annAnchorRealSrcSpan span) }) + +-- ------------------------------------- + +addTrailingDarrowC :: LocatedC a -> Located Token -> ApiAnnComments -> LocatedC a +addTrailingDarrowC (L (SrcSpanAnn ApiAnnNotUsed l) a) lt cs = + let + u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax + in L (SrcSpanAnn (ApiAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a +addTrailingDarrowC (L (SrcSpanAnn (ApiAnn lr (AnnContext _ o c) csc) l) a) lt cs = + let + u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax + in L (SrcSpanAnn (ApiAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a + +-- ------------------------------------- + +-- We need a location for the where binds, when computing the SrcSpan +-- for the AST element using them. Where there is a span, we return +-- it, else noLoc, which is ignored in the comb2 call. +adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs)) -> Located (HsLocalBinds GhcPs) +adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField) +adaptWhereBinds (Just b) = b + } diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index 9d158c95b7..3dd3b3302b 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -6,15 +6,11 @@ module GHC.Parser.Annotation ( -- * Out-of-tree API Annotations. Exist for the duration of !5158, -- * will be removed by !2418 - getAnnotation, getAndRemoveAnnotation, - getAnnotationComments,getAndRemoveAnnotationComments, ApiAnns(..), - ApiAnnKey, - AddAnn(..), mkParensApiAnn, -- * Core API Annotation types AnnKeywordId(..), - AnnotationComment(..), + AnnotationComment(..), AnnotationCommentTok(..), IsUnicodeSyntax(..), unicodeAnn, HasE(..), @@ -67,6 +63,7 @@ module GHC.Parser.Annotation ( getLocAnn, apiAnnAnns, apiAnnAnnsL, annParen2AddApiAnn, + apiAnnComments, -- ** Working with locations of annotations sortLocatedA, @@ -93,7 +90,6 @@ import GHC.Prelude import Data.Data import Data.Function (on) import Data.List (sortBy) -import qualified Data.Map as Map import Data.Semigroup import GHC.Data.FastString import GHC.Types.Name @@ -133,7 +129,7 @@ and GHC.Parser.PostProcess (which actually add the annotations). COMMENT ELEMENTS We associate comments with the lowest (most specific) AST element -enclosing them: +enclosing them PARSER STATE @@ -156,11 +152,11 @@ which takes the AST element RealSrcSpan, the annotation keyword and the target RealSrcSpan. This adds the annotation to the `annotations` field of `PState` and -transfers any comments in `comment_q` WHICH ARE ENCLOSED by -the RealSrcSpan of this element to the `annotations_comments` -field. (Comments which are outside of this annotation are deferred -until later. 'allocateComments' in 'Lexer' is responsible for -making sure we only attach comments that actually fit in the 'SrcSpan'.) +transfers any comments in `comment_q` WHICH ARE ENCLOSED by the +RealSrcSpan of this element to the `annotations_comments` field in +`PState`. (Comments which are outside of this annotation are deferred +until later. 'allocateComments' in 'Lexer' is responsible for making +sure we only attach comments that actually fit in the 'SrcSpan'.) The wiki page describing this feature is https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations @@ -168,102 +164,11 @@ https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations -} -- --------------------------------------------------------------------- --- This section should be removed when we move to the new APi Annotations - - data ApiAnns = ApiAnns - { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan], - apiAnnEofPos :: Maybe RealSrcSpan, - apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment], - apiAnnRogueComments :: [RealLocated AnnotationComment] + { apiAnnRogueComments :: [LAnnotationComment] } --- If you update this, update the Note [Api annotations] above -type ApiAnnKey = (RealSrcSpan,AnnKeywordId) - - --- --------------------------------------------------------------------- - --- | Encapsulated call to addAnnotation, requiring only the SrcSpan of --- the AST construct the annotation belongs to; together with the --- AnnKeywordId, this is the key of the annotation map. --- --- This type is useful for places in the parser where it is not yet --- known what SrcSpan an annotation should be added to. The most --- common situation is when we are parsing a list: the annotations --- need to be associated with the AST element that *contains* the --- list, not the list itself. 'AddAnn' lets us defer adding the --- annotations until we finish parsing the list and are now parsing --- the enclosing element; we then apply the 'AddAnn' to associate --- the annotations. Another common situation is where a common fragment of --- the AST has been factored out but there is no separate AST node for --- this fragment (this occurs in class and data declarations). In this --- case, the annotation belongs to the parent data declaration. --- --- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") --- function, and then it can be discharged using the 'ams' function. -data AddAnn = AddAnn AnnKeywordId SrcSpan - --- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate --- 'AddAnn' values for the opening and closing bordering on the start --- and end of the span -mkParensApiAnn :: SrcSpan -> [AddAnn] -mkParensApiAnn (UnhelpfulSpan _) = [] -mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc] - where - f = srcSpanFile ss - sl = srcSpanStartLine ss - sc = srcSpanStartCol ss - el = srcSpanEndLine ss - ec = srcSpanEndCol ss - lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing - lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing - --- --------------------------------------------------------------------- --- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' --- of the annotated AST element, and the known type of the annotation. -getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan] -getAnnotation anns span ann = - case Map.lookup ann_key ann_items of - Nothing -> [] - Just ss -> ss - where ann_items = apiAnnItems anns - ann_key = (span,ann) - --- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' --- of the annotated AST element, and the known type of the annotation. --- The list is removed from the annotations. -getAndRemoveAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId - -> ([RealSrcSpan],ApiAnns) -getAndRemoveAnnotation anns span ann = - case Map.lookup ann_key ann_items of - Nothing -> ([],anns) - Just ss -> (ss,anns{ apiAnnItems = Map.delete ann_key ann_items }) - where ann_items = apiAnnItems anns - ann_key = (span,ann) - --- |Retrieve the comments allocated to the current 'SrcSpan' --- --- Note: A given 'SrcSpan' may appear in multiple AST elements, --- beware of duplicates -getAnnotationComments :: ApiAnns -> RealSrcSpan -> [RealLocated AnnotationComment] -getAnnotationComments anns span = - case Map.lookup span (apiAnnComments anns) of - Just cs -> cs - Nothing -> [] - --- |Retrieve the comments allocated to the current 'SrcSpan', and --- remove them from the annotations -getAndRemoveAnnotationComments :: ApiAnns -> RealSrcSpan - -> ([RealLocated AnnotationComment],ApiAnns) -getAndRemoveAnnotationComments anns span = - case Map.lookup span ann_comments of - Just cs -> (cs, anns{ apiAnnComments = Map.delete span ann_comments }) - Nothing -> ([], anns) - where ann_comments = apiAnnComments anns - --- End of section to be removed with new API Annotations -- -------------------------------------------------------------------- -- | API Annotations exist so that tools can perform source to source @@ -277,6 +182,7 @@ getAndRemoveAnnotationComments anns span = -- -- The wiki page describing this feature is -- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations +-- https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow/in-tree-api-annotations -- -- Note: in general the names of these are taken from the -- corresponding token, unless otherwise noted @@ -394,7 +300,14 @@ instance Outputable AnnKeywordId where -- --------------------------------------------------------------------- -data AnnotationComment = +data AnnotationComment = AnnComment { ac_tok :: AnnotationCommentTok + , ac_prior_tok :: RealSrcSpan + -- ^ The location of the prior + -- token, used for exact printing + } + deriving (Eq, Ord, Data, Show) + +data AnnotationCommentTok = -- Documentation annotations AnnDocCommentNext String -- ^ something beginning '-- |' | AnnDocCommentPrev String -- ^ something beginning '-- ^' @@ -403,6 +316,8 @@ data AnnotationComment = | AnnDocOptions String -- ^ doc options (prune, ignore-exports, etc) | AnnLineComment String -- ^ comment starting by "--" | AnnBlockComment String -- ^ comment in {- -} + | AnnEofComment -- ^ empty comment, capturing + -- location of EOF deriving (Eq, Ord, Data, Show) -- Note: these are based on the Token versions, but the Token type is -- defined in GHC.Parser.Lexer and bringing it in here would create a loop @@ -525,6 +440,8 @@ From GHC 9.2.1, these annotations are captured directly in the AST, using the types in this file, and the Trees That Grow (TTG) extension points for GhcPs. +See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations + See Note [XRec and Anno in the AST] for details of how this is done. -} @@ -1056,10 +973,9 @@ annParen2AddApiAnn (ApiAnn _ (AnnParen pt o c) _) where (ai,ac) = parenTypeKws pt --- TODO: enable when we migrate --- apiAnnComments :: ApiAnn' an -> ApiAnnComments --- apiAnnComments ApiAnnNotUsed = AnnComments [] --- apiAnnComments (ApiAnn _ _ cs) = cs +apiAnnComments :: ApiAnn' an -> ApiAnnComments +apiAnnComments ApiAnnNotUsed = AnnComments [] +apiAnnComments (ApiAnn _ _ cs) = cs -- --------------------------------------------------------------------- -- sortLocatedA :: [LocatedA a] -> [LocatedA a] diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 47c8104fd1..2bfefb41ed 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} module GHC.Parser.Errors.Ppr ( pprWarning @@ -506,6 +507,7 @@ pp_err = \case -- so check for that, and suggest. cf #3805 -- Sadly 'foreign import' still barfs 'parse error' because -- 'import' is a keyword + -- looks_like :: RdrName -> LHsExpr GhcPs -> Bool -- AZ looks_like s (L _ (HsVar _ (L _ v))) = v == s looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs looks_like _ _ = False diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 5d911a0b56..7b561f2119 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -139,18 +139,19 @@ mkPrelImports this_mod loc implicit_prelude import_decls Just b -> sl_fs b == unitIdFS baseUnitId + loc' = noAnnSrcSpan loc preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = L loc $ ImportDecl { ideclExt = noExtField, - ideclSourceSrc = NoSourceText, - ideclName = L loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = NotBoot, - ideclSafe = False, -- Not a safe import - ideclQualified = NotQualified, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } + = L loc' $ ImportDecl { ideclExt = noAnn, + ideclSourceSrc = NoSourceText, + ideclName = L loc pRELUDE_NAME, + ideclPkgQual = Nothing, + ideclSource = NotBoot, + ideclSafe = False, -- Not a safe import + ideclQualified = NotQualified, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } -------------------------------------------------------------- -- Get options @@ -268,8 +269,8 @@ getOptions' dflags toks = map (L (getLoc open)) ["-#include",removeSpaces str] ++ parseToks xs parseToks (open:close:xs) - | ITdocOptions str <- unLoc open - , ITclose_prag <- unLoc close + | ITdocOptions str _ <- unLoc open + , ITclose_prag <- unLoc close = map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++ parseToks xs parseToks (open:xs) diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 71fccbe7c5..bfebbfa411 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -42,6 +42,7 @@ { {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -53,7 +54,7 @@ module GHC.Parser.Lexer ( ParserOpts(..), mkParserOpts, PState (..), initParserState, initPragState, P(..), ParseResult(..), - allocateComments, + allocateComments, allocatePriorComments, allocateFinalComments, MonadP(..), getRealSrcLoc, getPState, failMsgP, failLocMsgP, srcParseFail, @@ -64,7 +65,9 @@ module GHC.Parser.Lexer ( ExtBits(..), xtest, xunset, xset, lexTokenStream, - addAnnsAt, + mkParensApiAnn, + getCommentsFor, getPriorCommentsFor, getFinalCommentsFor, + getEofPos, commentToAnnotation, HdkComment(..), warnopt, @@ -76,7 +79,7 @@ import GHC.Prelude import Control.Monad import Data.Bits import Data.Char -import Data.List (stripPrefix, isInfixOf) +import Data.List (stripPrefix, isInfixOf, partition) import Data.Maybe import Data.Word @@ -869,20 +872,37 @@ data Token | ITunknown String -- ^ Used when the lexer can't make sense of it | ITeof -- ^ end of file token - -- Documentation annotations - | ITdocCommentNext String -- ^ something beginning @-- |@ - | ITdocCommentPrev String -- ^ something beginning @-- ^@ - | ITdocCommentNamed String -- ^ something beginning @-- $@ - | ITdocSection Int String -- ^ a section heading - | ITdocOptions String -- ^ doc options (prune, ignore-exports, etc) - | ITlineComment String -- ^ comment starting by "--" - | ITblockComment String -- ^ comment in {- -} + -- Documentation annotations. See Note [PsSpan in Comments] + | ITdocCommentNext String PsSpan -- ^ something beginning @-- |@ + | ITdocCommentPrev String PsSpan -- ^ something beginning @-- ^@ + | ITdocCommentNamed String PsSpan -- ^ something beginning @-- $@ + | ITdocSection Int String PsSpan -- ^ a section heading + | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) + | ITlineComment String PsSpan -- ^ comment starting by "--" + | ITblockComment String PsSpan -- ^ comment in {- -} deriving Show instance Outputable Token where ppr x = text (show x) +{- Note [PsSpan in Comments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When using the Api Annotations to exact print a modified AST, managing +the space before a comment is important. The PsSpan in the comment +token allows this to happen. + +We also need to track the space before the end of file. The normal +mechanism of using the previous token does not work, as the ITeof is +synthesised to come at the same location of the last token, and the +normal previous token updating has by then updated the required +location. + +We track this using a 2-back location, prev_loc2. This adds extra +processing to every single token, which is a performance hit for +something needed only at the end of the file. This needs +improving. Perhaps a backward scan on eof? +-} {- Note [Minus tokens] ~~~~~~~~~~~~~~~~~~~~~~ @@ -1290,7 +1310,11 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "") lineCommentToken :: Action lineCommentToken span buf len = do b <- getBit RawTokenStreamBit - if b then strtoken ITlineComment span buf len else lexToken + if b then do + lt <- getLastLocComment + strtoken (\s -> ITlineComment s lt) span buf len + else lexToken + {- nested comments require traversing by hand, they can't be parsed @@ -1302,7 +1326,8 @@ nested_comment cont span buf len = do go (reverse $ lexemeToString buf len) (1::Int) input where go commentAcc 0 input = do - let finalizeComment str = (Nothing, ITblockComment str) + l <- getLastLocComment + let finalizeComment str = (Nothing, ITblockComment str l) commentEnd cont input commentAcc finalizeComment buf span go commentAcc n input = case alexGetChar' input of Nothing -> errBrace input (psRealSpan span) @@ -1397,32 +1422,33 @@ withLexedDocType :: (AlexInput -> (String -> (HdkComment, Token)) -> Bool -> P ( -> P (PsLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput + l <- getLastLocComment case prevChar buf ' ' of -- The `Bool` argument to lexDocComment signals whether or not the next -- line of input might also belong to this doc comment. - '|' -> lexDocComment input mkHdkCommentNext True - '^' -> lexDocComment input mkHdkCommentPrev True - '$' -> lexDocComment input mkHdkCommentNamed True - '*' -> lexDocSection 1 input + '|' -> lexDocComment input (mkHdkCommentNext l) True + '^' -> lexDocComment input (mkHdkCommentPrev l) True + '$' -> lexDocComment input (mkHdkCommentNamed l) True + '*' -> lexDocSection l 1 input _ -> panic "withLexedDocType: Bad doc type" where - lexDocSection n input = case alexGetChar' input of - Just ('*', input) -> lexDocSection (n+1) input - Just (_, _) -> lexDocComment input (mkHdkCommentSection n) False + lexDocSection l n input = case alexGetChar' input of + Just ('*', input) -> lexDocSection l (n+1) input + Just (_, _) -> lexDocComment input (mkHdkCommentSection l n) False Nothing -> do setInput input; lexToken -- eof reached, lex it normally -mkHdkCommentNext, mkHdkCommentPrev :: String -> (HdkComment, Token) -mkHdkCommentNext str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str) -mkHdkCommentPrev str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str) +mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> String -> (HdkComment, Token) +mkHdkCommentNext loc str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str loc) +mkHdkCommentPrev loc str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str loc) -mkHdkCommentNamed :: String -> (HdkComment, Token) -mkHdkCommentNamed str = +mkHdkCommentNamed :: PsSpan -> String -> (HdkComment, Token) +mkHdkCommentNamed loc str = let (name, rest) = break isSpace str - in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str) + in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str loc) -mkHdkCommentSection :: Int -> String -> (HdkComment, Token) -mkHdkCommentSection n str = - (HdkCommentSection n (mkHsDocString str), ITdocSection n str) +mkHdkCommentSection :: PsSpan -> Int -> String -> (HdkComment, Token) +mkHdkCommentSection loc n str = + (HdkCommentSection n (mkHsDocString str), ITdocSection n str loc) -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma. @@ -1551,7 +1577,7 @@ varid span buf len = Just (ITcase, _) -> do lastTk <- getLastTk keyword <- case lastTk of - Just ITlam -> do + Just (L _ ITlam) -> do lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState @@ -1888,19 +1914,26 @@ alrInitialLoc file = mkRealSrcSpan loc loc -- ----------------------------------------------------------------------------- -- Options, includes and language pragmas. + lex_string_prag :: (String -> Token) -> Action -lex_string_prag mkTok span _buf _len +lex_string_prag mkTok = lex_string_prag_comment mkTok' + where + mkTok' s _ = mkTok s + +lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action +lex_string_prag_comment mkTok span _buf _len = do input <- getInput start <- getParsedLoc - tok <- go [] input + l <- getLastLocComment + tok <- go l [] input end <- getParsedLoc return (L (mkPsSpan start end) tok) - where go acc input + where go l acc input = if isString input "#-}" then do setInput input - return (mkTok (reverse acc)) + return (mkTok (reverse acc) l) else case alexGetChar input of - Just (c,i) -> go (c:acc) i + Just (c,i) -> go l (c:acc) i Nothing -> err input isString _ [] = True isString i (x:xs) @@ -1909,7 +1942,6 @@ lex_string_prag mkTok span _buf _len _other -> False err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) []) - -- ----------------------------------------------------------------------------- -- Strings & Chars @@ -2282,9 +2314,12 @@ data PState = PState { errors :: Bag PsError, tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file tab_count :: !Word, -- number of tab warnings in the file - last_tk :: Maybe Token, - last_loc :: PsSpan, -- pos of previous token - last_len :: !Int, -- len of previous token + last_tk :: Maybe (PsLocated Token), -- last non-comment token + prev_loc :: PsSpan, -- pos of previous token, including comments, + prev_loc2 :: PsSpan, -- pos of two back token, including comments, + -- see Note [PsSpan in Comments] + last_loc :: PsSpan, -- pos of current token + last_len :: !Int, -- len of current token loc :: PsLoc, -- current loc (end of prev token + 1) context :: [LayoutContext], lex_state :: [Int], @@ -2312,10 +2347,9 @@ data PState = PState { -- locations of 'noise' tokens in the source, so that users of -- the GHC API can do source to source conversions. -- See note [Api annotations] in GHC.Parser.Annotation - annotations :: [(ApiAnnKey,[RealSrcSpan])], - eof_pos :: Maybe RealSrcSpan, - comment_q :: [RealLocated AnnotationComment], - annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])], + eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token + header_comments :: Maybe [LAnnotationComment], + comment_q :: [LAnnotationComment], -- Haddock comments accumulated in ascending order of their location -- (BufPos). We use OrdList to get O(1) snoc. @@ -2329,6 +2363,12 @@ data PState = PState { -- Getting rid of last_loc would require finding another way to -- implement pushCurrentContext (which is only called from one place). + -- AZ question: setLastToken which sets last_loc and last_len + -- is called whan processing AlexToken, immediately prior to + -- calling the action in the token. So from the perspective + -- of the action, it is the *current* token. Do I understand + -- correctly? + data ALRContext = ALRNoLayout Bool{- does it contain commas? -} Bool{- is it a 'let' block? -} | ALRLayout ALRLayout Int @@ -2395,8 +2435,8 @@ getParsedLoc = P $ \s@(PState{ loc=loc }) -> POk s loc addSrcFile :: FastString -> P () addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () -setEofPos :: RealSrcSpan -> P () -setEofPos span = P $ \s -> POk s{ eof_pos = Just span } () +setEofPos :: RealSrcSpan -> RealSrcSpan -> P () +setEofPos span gap = P $ \s -> POk s{ eof_pos = Just (span, gap) } () setLastToken :: PsSpan -> Int -> P () setLastToken loc len = P $ \s -> POk s { @@ -2404,12 +2444,29 @@ setLastToken loc len = P $ \s -> POk s { last_len=len } () -setLastTk :: Token -> P () -setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () +setLastTk :: PsLocated Token -> P () +setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Just tk + , prev_loc = l + , prev_loc2 = prev_loc s} () -getLastTk :: P (Maybe Token) +setLastComment :: PsLocated Token -> P () +setLastComment (L l _) = P $ \s -> POk s { prev_loc = l + , prev_loc2 = prev_loc s} () + +getLastTk :: P (Maybe (PsLocated Token)) getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk +-- see Note [PsSpan in Comments] +getLastLocComment :: P PsSpan +getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc + +-- see Note [PsSpan in Comments] +getLastLocEof :: P PsSpan +getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2 + +getLastLoc :: P PsSpan +getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc + data AlexInput = AI !PsLoc !StringBuffer {- @@ -2778,6 +2835,8 @@ initParserState options buf loc = tab_first = Nothing, tab_count = 0, last_tk = Nothing, + prev_loc = mkPsSpan init_loc init_loc, + prev_loc2 = mkPsSpan init_loc init_loc, last_loc = mkPsSpan init_loc init_loc, last_len = 0, loc = init_loc, @@ -2790,10 +2849,9 @@ initParserState options buf loc = alr_context = [], alr_expecting_ocurly = Nothing, alr_justClosedExplicitLetBlock = False, - annotations = [], eof_pos = Nothing, + header_comments = Nothing, comment_q = [], - annotations_comments = [], hdk_comments = nilOL } where init_loc = PsLoc loc (BufPos 0) @@ -2832,12 +2890,15 @@ class Monad m => MonadP m where -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool - - -- | Given a location and a list of AddAnn, apply them all to the location. - addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct - -> AnnKeywordId -- The first two parameters are the key - -> SrcSpan -- The location of the keyword itself - -> m () + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that belong within the given span + allocateCommentsP :: RealSrcSpan -> m ApiAnnComments + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that come before or within the given span + allocatePriorCommentsP :: RealSrcSpan -> m ApiAnnComments + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that come after the given span + allocateFinalCommentsP :: RealSrcSpan -> m ApiAnnComments instance MonadP P where addError err @@ -2853,14 +2914,40 @@ instance MonadP P where getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) in b `seq` POk s b - - addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do - addAnnotationOnly l a v - allocateCommentsP l - addAnnotation _ _ _ = return () - -addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m () -addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v) + allocateCommentsP ss = P $ \s -> + let (comment_q', newAnns) = allocateComments ss (comment_q s) in + POk s { + comment_q = comment_q' + } (AnnComments newAnns) + allocatePriorCommentsP ss = P $ \s -> + let (header_comments', comment_q', newAnns) + = allocatePriorComments ss (comment_q s) (header_comments s) in + POk s { + header_comments = header_comments', + comment_q = comment_q' + } (AnnComments newAnns) + allocateFinalCommentsP ss = P $ \s -> + let (header_comments', comment_q', newAnns) + = allocateFinalComments ss (comment_q s) (header_comments s) in + POk s { + header_comments = header_comments', + comment_q = comment_q' + } (AnnCommentsBalanced [] (reverse newAnns)) + +getCommentsFor :: (MonadP m) => SrcSpan -> m ApiAnnComments +getCommentsFor (RealSrcSpan l _) = allocateCommentsP l +getCommentsFor _ = return noCom + +getPriorCommentsFor :: (MonadP m) => SrcSpan -> m ApiAnnComments +getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l +getPriorCommentsFor _ = return noCom + +getFinalCommentsFor :: (MonadP m) => SrcSpan -> m ApiAnnComments +getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l +getFinalCommentsFor _ = return noCom + +getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan)) +getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan @@ -3213,7 +3300,8 @@ lexToken = do case alexScanUser exts inp sc of AlexEOF -> do let span = mkPsSpan loc1 loc1 - setEofPos (psRealSpan span) + lt <- getLastLocEof + setEofPos (psRealSpan span) (psRealSpan lt) setLastToken span 0 return (L span ITeof) AlexError (AI loc2 buf) -> @@ -3229,7 +3317,7 @@ lexToken = do span `seq` setLastToken span bytes lt <- t span buf bytes let lt' = unLoc lt - unless (isComment lt') (setLastTk lt') + if (isComment lt') then setLastComment lt else setLastTk lt return lt reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a @@ -3260,7 +3348,7 @@ linePrags = Map.singleton "line" linePrag fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), ("options_ghc", lex_string_prag IToptions_prag), - ("options_haddock", lex_string_prag ITdocOptions), + ("options_haddock", lex_string_prag_comment ITdocOptions), ("language", token ITlanguage_prag), ("include", lex_string_prag ITinclude_prag)]) @@ -3346,61 +3434,94 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) -} -addAnnotationOnly :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P () -addAnnotationOnly l a v = P $ \s -> POk s { - annotations = ((l,a), [v]) : annotations s - } () - +-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'AddApiAnn' values for the opening and closing bordering on the start +-- and end of the span +mkParensApiAnn :: SrcSpan -> [AddApiAnn] +mkParensApiAnn (UnhelpfulSpan _) = [] +mkParensApiAnn (RealSrcSpan ss _) = [AddApiAnn AnnOpenP (AR lo),AddApiAnn AnnCloseP (AR lc)] + where + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) + lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) queueComment :: RealLocated Token -> P() queueComment c = P $ \s -> POk s { comment_q = commentToAnnotation c : comment_q s } () --- | Go through the @comment_q@ in @PState@ and remove all comments --- that belong within the given span -allocateCommentsP :: RealSrcSpan -> P () -allocateCommentsP ss = P $ \s -> - let (comment_q', newAnns) = allocateComments ss (comment_q s) in - POk s { - comment_q = comment_q' - , annotations_comments = newAnns ++ (annotations_comments s) - } () - allocateComments :: RealSrcSpan - -> [RealLocated AnnotationComment] - -> ([RealLocated AnnotationComment], [(RealSrcSpan,[RealLocated AnnotationComment])]) + -> [LAnnotationComment] + -> ([LAnnotationComment], [LAnnotationComment]) allocateComments ss comment_q = let - (before,rest) = break (\(L l _) -> isRealSubspanOf l ss) comment_q - (middle,after) = break (\(L l _) -> not (isRealSubspanOf l ss)) rest + (before,rest) = break (\(L l _) -> isRealSubspanOf (anchor l) ss) comment_q + (middle,after) = break (\(L l _) -> not (isRealSubspanOf (anchor l) ss)) rest comment_q' = before ++ after - newAnns = if null middle then [] - else [(ss,middle)] + newAnns = middle in (comment_q', newAnns) +allocatePriorComments + :: RealSrcSpan + -> [LAnnotationComment] + -> Maybe [LAnnotationComment] + -> (Maybe [LAnnotationComment], [LAnnotationComment], [LAnnotationComment]) +allocatePriorComments ss comment_q mheader_comments = + let + cmp (L l _) = anchor l <= ss + (before,after) = partition cmp comment_q + newAnns = before + comment_q'= after + in + case mheader_comments of + Nothing -> (Just newAnns, comment_q', []) + Just _ -> (mheader_comments, comment_q', newAnns) -commentToAnnotation :: RealLocated Token -> RealLocated AnnotationComment -commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) -commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) -commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) -commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) -commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) -commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) -commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) +allocateFinalComments + :: RealSrcSpan + -> [LAnnotationComment] + -> Maybe [LAnnotationComment] + -> (Maybe [LAnnotationComment], [LAnnotationComment], [LAnnotationComment]) +allocateFinalComments ss comment_q mheader_comments = + let + cmp (L l _) = anchor l <= ss + (before,after) = partition cmp comment_q + newAnns = after + comment_q'= before + in + case mheader_comments of + Nothing -> (Just newAnns, comment_q', []) + Just _ -> (mheader_comments, comment_q', newAnns) + +commentToAnnotation :: RealLocated Token -> LAnnotationComment +commentToAnnotation (L l (ITdocCommentNext s ll)) = mkLAnnotationComment l ll (AnnDocCommentNext s) +commentToAnnotation (L l (ITdocCommentPrev s ll)) = mkLAnnotationComment l ll (AnnDocCommentPrev s) +commentToAnnotation (L l (ITdocCommentNamed s ll)) = mkLAnnotationComment l ll (AnnDocCommentNamed s) +commentToAnnotation (L l (ITdocSection n s ll)) = mkLAnnotationComment l ll (AnnDocSection n s) +commentToAnnotation (L l (ITdocOptions s ll)) = mkLAnnotationComment l ll (AnnDocOptions s) +commentToAnnotation (L l (ITlineComment s ll)) = mkLAnnotationComment l ll (AnnLineComment s) +commentToAnnotation (L l (ITblockComment s ll)) = mkLAnnotationComment l ll (AnnBlockComment s) commentToAnnotation _ = panic "commentToAnnotation" +-- see Note [PsSpan in Comments] +mkLAnnotationComment :: RealSrcSpan -> PsSpan -> AnnotationCommentTok -> LAnnotationComment +mkLAnnotationComment l ll tok = L (realSpanAsAnchor l) (AnnComment tok (psRealSpan ll)) + -- --------------------------------------------------------------------- isComment :: Token -> Bool -isComment (ITlineComment _) = True -isComment (ITblockComment _) = True -isComment (ITdocCommentNext _) = True -isComment (ITdocCommentPrev _) = True -isComment (ITdocCommentNamed _) = True -isComment (ITdocSection _ _) = True -isComment (ITdocOptions _) = True +isComment (ITlineComment _ _) = True +isComment (ITblockComment _ _) = True +isComment (ITdocCommentNext _ _) = True +isComment (ITdocCommentPrev _ _) = True +isComment (ITdocCommentNamed _ _) = True +isComment (ITdocSection _ _ _) = True +isComment (ITdocOptions _ _) = True isComment _ = False } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 6a0f86aefe..9bf87b2e8b 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -34,6 +35,7 @@ module GHC.Parser.PostProcess ( mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace, fromSpecTyVarBndr, fromSpecTyVarBndrs, + annBinds, cvBindGroup, cvBindsAndSigs, @@ -45,7 +47,7 @@ module GHC.Parser.PostProcess ( parseCImport, mkExport, mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkGadtDecl, -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName mkConDeclH98, -- Bunch of functions in the parser monad for @@ -109,7 +111,7 @@ module GHC.Parser.PostProcess ( import GHC.Prelude import GHC.Hs -- Lots of it import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import GHC.Core.DataCon ( DataCon, dataConTyCon, FieldLabelString ) +import GHC.Core.DataCon ( DataCon, dataConTyCon ) import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader @@ -136,11 +138,11 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Parser.Annotation import Data.Either import Data.List import Data.Foldable import GHC.Driver.Flags ( WarningFlag(..) ) +import qualified Data.Semigroup as Semi import GHC.Utils.Panic import Control.Monad @@ -178,17 +180,18 @@ mkClassDecl :: SrcSpan -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo - = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls - ; let cxt = mcxt +mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn + = do { let loc = noAnnSrcSpan loc' + ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams - ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; return (L loc (ClassDecl { tcdCExt = layoutInfo - , tcdCtxt = cxt + ; cs <- getCommentsFor (locA loc) -- Get any remaining comments + ; let anns' = addAnns (ApiAnn (spanAsAnchor $ locA loc) annsIn noCom) (ann++annst) cs + ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo) + , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity , tcdFDs = snd (unLoc fds) @@ -199,34 +202,37 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo mkTyData :: SrcSpan -> NewOrData - -> Maybe (Located CType) + -> Maybe (LocatedP CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] - -> HsDeriving GhcPs + -> Located (HsDeriving GhcPs) + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) - ksig data_cons maybe_deriv - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan +mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr)) + ksig data_cons (L _ maybe_deriv) annsIn + = do { let loc = noAnnSrcSpan loc' + ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataDecl { tcdDExt = noExtField, + ; cs <- getCommentsFor (locA loc) -- Get any remaining comments + ; let anns' = addAnns (ApiAnn (spanAsAnchor $ locA loc) annsIn noCom) (ann ++ anns) cs + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns' + ; return (L loc (DataDecl { tcdDExt = anns', -- AZ: do we need these? tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn })) } mkDataDefn :: NewOrData - -> Maybe (Located CType) + -> Maybe (LocatedP CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs + -> ApiAnn -> P (HsDataDefn GhcPs) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv +mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ann = do { checkDatatypeContext mcxt - ; return (HsDataDefn { dd_ext = noExtField + ; return (HsDataDefn { dd_ext = ann , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = mcxt , dd_cons = data_cons @@ -237,67 +243,79 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv mkTySynonym :: SrcSpan -> LHsType GhcPs -- LHS -> LHsType GhcPs -- RHS + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkTySynonym loc lhs rhs +mkTySynonym loc lhs rhs annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (L loc (SynDecl { tcdSExt = noExtField + ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] + ; let anns' = addAnns (ApiAnn (spanAsAnchor loc) annsIn noCom) (ann ++ anns) (cs1 Semi.<> cs2) + ; return (L (noAnnSrcSpan loc) (SynDecl + { tcdSExt = anns' , tcdLName = tc, tcdTyVars = tyvars , tcdFixity = fixity , tcdRhs = rhs })) } mkStandaloneKindSig :: SrcSpan - -> Located [Located RdrName] -- LHS - -> LHsSigType GhcPs -- RHS + -> Located [LocatedN RdrName] -- LHS + -> LHsSigType GhcPs -- RHS + -> [AddApiAnn] -> P (LStandaloneKindSig GhcPs) -mkStandaloneKindSig loc lhs rhs = +mkStandaloneKindSig loc lhs rhs anns = do { vs <- mapM check_lhs_name (unLoc lhs) ; v <- check_singular_lhs (reverse vs) - ; return $ L loc $ StandaloneKindSig noExtField v rhs } + ; cs <- getCommentsFor loc + ; return $ L (noAnnSrcSpan loc) + $ StandaloneKindSig (ApiAnn (spanAsAnchor loc) anns cs) v rhs } where check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v - else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v) + else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs) -mkTyFamInstEqn :: HsOuterFamEqnTyVarBndrs GhcPs +mkTyFamInstEqn :: SrcSpan + -> HsOuterFamEqnTyVarBndrs GhcPs -> LHsType GhcPs -> LHsType GhcPs - -> P (TyFamInstEqn GhcPs,[AddAnn]) -mkTyFamInstEqn bndrs lhs rhs + -> [AddApiAnn] + -> P (LTyFamInstEqn GhcPs) +mkTyFamInstEqn loc bndrs lhs rhs anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; return (FamEqn { feqn_ext = noExtField + ; cs <- getCommentsFor loc + ; return (L (noAnnSrcSpan loc) $ FamEqn + { feqn_ext = ApiAnn (spanAsAnchor loc) (anns `mappend` ann) cs , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams , feqn_fixity = fixity - , feqn_rhs = rhs }, - ann) } + , feqn_rhs = rhs })} mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (Located CType) + -> Maybe (LocatedP CType) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] - -> HsDeriving GhcPs + -> Located (HsDeriving GhcPs) + -> [AddApiAnn] -> P (LInstDecl GhcPs) mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) - ksig data_cons maybe_deriv + ksig data_cons (L _ maybe_deriv) anns = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataFamInstD noExtField (DataFamInstDecl - (FamEqn { feqn_ext = noExtField + ; -- AZ:TODO: deal with these comments + ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] + ; let anns' = addAnns (ApiAnn (spanAsAnchor loc) ann cs) anns noCom + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns' + ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl + (FamEqn { feqn_ext = noAnn -- AZ: get anns , feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tparams @@ -306,23 +324,31 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs + -> [AddApiAnn] -> P (LInstDecl GhcPs) -mkTyFamInst loc eqn - = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn))) +mkTyFamInst loc eqn anns = do + cs <- getCommentsFor loc + return (L (noAnnSrcSpan loc) (TyFamInstD noExtField + (TyFamInstDecl (ApiAnn (spanAsAnchor loc) anns cs) eqn))) mkFamDecl :: SrcSpan -> FamilyInfo GhcPs + -> TopLevelFlag -> LHsType GhcPs -- LHS -> Located (FamilyResultSig GhcPs) -- Optional result signature -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> [AddApiAnn] -> P (LTyClDecl GhcPs) -mkFamDecl loc info lhs ksig injAnn +mkFamDecl loc info topLevel lhs ksig injAnn annsIn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan - ; return (L loc (FamDecl noExtField (FamilyDecl - { fdExt = noExtField + ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] + ; let anns' = addAnns (ApiAnn (spanAsAnchor loc) annsIn noCom) (ann++anns) (cs1 Semi.<> cs2) + ; return (L (noAnnSrcSpan loc) (FamDecl noExtField + (FamilyDecl + { fdExt = anns' + , fdTopLevel = topLevel , fdInfo = info, fdLName = tc , fdTyVars = tyvars , fdFixity = fixity @@ -334,7 +360,7 @@ mkFamDecl loc info lhs ksig injAnn OpenTypeFamily -> empty ClosedTypeFamily {} -> whereDots -mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs +mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs) -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD @@ -345,23 +371,30 @@ mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs -- Typed splices are not allowed at the top level, thus we do not represent them -- as spliced declaration. See #10945 mkSpliceDecl lexpr@(L loc expr) - | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = do + cs <- getCommentsFor (locA loc) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) - | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr - = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = do + cs <- getCommentsFor (locA loc) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) - | otherwise - = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr)) - ImplicitSplice) + | otherwise = do + cs <- getCommentsFor (locA loc) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField + (L loc (mkUntypedSplice noAnn BareSplice lexpr)) + ImplicitSplice) mkRoleAnnotDecl :: SrcSpan - -> Located RdrName -- type being annotated - -> [Located (Maybe FastString)] -- roles + -> LocatedN RdrName -- type being annotated + -> [Located (Maybe FastString)] -- roles + -> [AddApiAnn] -> P (LRoleAnnotDecl GhcPs) -mkRoleAnnotDecl loc tycon roles +mkRoleAnnotDecl loc tycon roles anns = do { roles' <- mapM parse_role roles - ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' } + ; cs <- getCommentsFor loc + ; return $ L (noAnnSrcSpan loc) + $ RoleAnnotDecl (ApiAnn (spanAsAnchor loc) anns cs) tycon roles' } where role_data_type = dataTypeOf (undefined :: Role) all_roles = map fromConstr $ dataTypeConstrs role_data_type @@ -393,9 +426,37 @@ fromSpecTyVarBndr bndr = case bndr of (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc) >> return (L loc $ KindedTyVar xtv () idp k) where - check_spec :: Specificity -> SrcSpan -> P () + check_spec :: Specificity -> SrcSpanAnnA -> P () check_spec SpecifiedSpec _ = return () - check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] loc + check_spec InferredSpec loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc) + +-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ +annBinds :: AddApiAnn -> HsLocalBinds GhcPs -> HsLocalBinds GhcPs +annBinds a (HsValBinds an bs) = (HsValBinds (add_where a an) bs) +annBinds a (HsIPBinds an bs) = (HsIPBinds (add_where a an) bs) +annBinds _ (EmptyLocalBinds x) = (EmptyLocalBinds x) + +add_where :: AddApiAnn -> ApiAnn' AnnList -> ApiAnn' AnnList +add_where an@(AddApiAnn _ (AR rs)) (ApiAnn a (AnnList anc o c r t) cs) + | valid_anchor (anchor a) + = ApiAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) cs + | otherwise + = ApiAnn (patch_anchor rs a) (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) cs +add_where an@(AddApiAnn _ (AR rs)) ApiAnnNotUsed + = ApiAnn (Anchor rs UnchangedAnchor) + (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) noCom +add_where (AddApiAnn _ (AD _)) _ = panic "add_where" + -- AD should only be used for transformations + +valid_anchor :: RealSrcSpan -> Bool +valid_anchor r = srcSpanStartLine r >= 0 + +-- If the decl list for where binds is empty, the anchor ends up +-- invalid. In this case, use the parent one +patch_anchor :: RealSrcSpan -> Anchor -> Anchor +patch_anchor r1 (Anchor r0 op) = Anchor r op + where + r = if srcSpanStartLine r0 < 0 then r1 else r0 {- ********************************************************************** @@ -418,11 +479,11 @@ cvBindGroup binding = do { (mbs, sigs, fam_ds, tfam_insts , dfam_insts, _) <- cvBindsAndSigs binding ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) - return $ ValBinds noExtField mbs sigs } + return $ ValBinds NoAnnSortKey mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] - , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) -- Input decls contain just value bindings and signatures -- and in case of class or instance declarations also -- associated type declarations. They might also contain Haddock comments. @@ -446,7 +507,7 @@ cvBindsAndSigs fb = do -- called on top-level declarations. drop_bad_decls [] = return [] drop_bad_decls (L l (SpliceD _ d) : ds) = do - addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] l + addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l) drop_bad_decls ds drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -475,18 +536,25 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) | has_args mtchs1 = go mtchs1 loc1 binds [] where + -- TODO:AZ may have to preserve annotations. Although they should + -- only be AnnSemi, and meaningless in this context? + go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA + -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] + -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ go mtchs loc ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) , fun_matches = - MG { mg_alts = (L _ mtchs2) } }))) + MG { mg_alts = (L _ [L lm2 mtchs2]) } }))) : binds) _ - | f1 == f2 = go (mtchs2 ++ mtchs) - (combineSrcSpans loc loc2) binds [] + | f1 == f2 = + let (loc2', lm2') = transferComments loc2 lm2 + in go (L lm2' mtchs2 : mtchs) + (combineSrcSpansA loc loc2') binds [] go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls = let doc_decls' = doc_decl : doc_decls - in go mtchs (combineSrcSpans loc loc2) binds doc_decls' + in go mtchs (combineSrcSpansA loc loc2) binds doc_decls' go mtchs loc binds doc_decls - = ( L loc (makeFunBind fun_id1 (reverse mtchs)) + = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs)) , (reverse doc_decls) ++ binds) -- Reverse the final matches, to get it back in the right order -- Do the same thing with the trailing doc comments @@ -551,32 +619,33 @@ constructor, a type, or a context, we would need unlimited lookahead which -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard] -tyConToDataCon :: SrcSpan -> RdrName -> Either PsError (Located RdrName) -tyConToDataCon loc tc +tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName) +tyConToDataCon (L loc tc) | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = Left $ PsError (PsErrNotADataCon tc) [] loc + = Left $ PsError (PsErrNotADataCon tc) [] (locA loc) where occ = rdrNameOcc tc -mkPatSynMatchGroup :: Located RdrName - -> Located (OrdList (LHsDecl GhcPs)) +mkPatSynMatchGroup :: LocatedN RdrName + -> LocatedL (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = +mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = do { matches <- mapM fromDecl (fromOL decls) - ; when (null matches) (wrongNumberErr loc) - ; return $ mkMatchGroup FromSource matches } + ; when (null matches) (wrongNumberErr (locA loc)) + ; return $ mkMatchGroup FromSource (L ld matches) } where fromDecl (L loc decl@(ValD _ (PatBind _ - pat@(L _ (ConPat NoExtField ln@(L _ name) details)) + -- AZ: where should these anns come from? + pat@(L _ (ConPat noAnn ln@(L _ name) details)) rhs _))) = do { unless (name == patsyn_name) $ - wrongNameBindingErr loc decl + wrongNameBindingErr (locA loc) decl ; match <- case details of - PrefixCon _ pats -> return $ Match { m_ext = noExtField + PrefixCon _ pats -> return $ Match { m_ext = noAnn , m_ctxt = ctxt, m_pats = pats , m_grhss = rhs } where @@ -584,7 +653,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = , mc_fixity = Prefix , mc_strictness = NoSrcStrict } - InfixCon p1 p2 -> return $ Match { m_ext = noExtField + InfixCon p1 p2 -> return $ Match { m_ext = noAnn , m_ctxt = ctxt , m_pats = [p1, p2] , m_grhss = rhs } @@ -593,9 +662,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = , mc_fixity = Infix , mc_strictness = NoSrcStrict } - RecCon{} -> recordPatSynErr loc pat + RecCon{} -> recordPatSynErr (locA loc) pat ; return $ L loc match } - fromDecl (L loc decl) = extraDeclErr loc decl + fromDecl (L loc decl) = extraDeclErr (locA loc) decl extraDeclErr loc decl = addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc @@ -610,14 +679,14 @@ recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] +mkConDeclH98 :: ApiAnn -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs -mkConDeclH98 name mb_forall mb_cxt args - = ConDeclH98 { con_ext = noExtField +mkConDeclH98 ann name mb_forall mb_cxt args + = ConDeclH98 { con_ext = ann , con_name = name - , con_forall = noLoc $ isJust mb_forall + , con_forall = isJust mb_forall , con_ex_tvs = mb_forall `orElse` [] , con_mb_cxt = mb_cxt , con_args = args @@ -630,25 +699,36 @@ mkConDeclH98 name mb_forall mb_cxt args -- provided), context (if provided), argument types, and result type, and -- records whether this is a prefix or record GADT constructor. See -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. -mkGadtDecl :: [Located RdrName] +mkGadtDecl :: SrcSpan + -> [LocatedN RdrName] -> LHsSigType GhcPs - -> P (ConDecl GhcPs, [AddAnn]) -mkGadtDecl names ty = do - let (args, res_ty, anns) - | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty - = (RecConGADT (L loc rf), res_ty, []) + -> [AddApiAnn] + -> P (LConDecl GhcPs) +mkGadtDecl loc names ty annsIn = do + cs <- getCommentsFor loc + let l = noAnnSrcSpan loc + + let (args, res_ty, annsa, csa) + | L ll (HsFunTy af _w (L loc' (HsRecTy an rf)) res_ty) <- body_ty + = let + an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an + in ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf), res_ty + , [], apiAnnComments (ann ll)) | otherwise - = let (arg_types, res_type, anns) = splitHsFunType body_ty - in (PrefixConGADT arg_types, res_type, anns) + = let (anns, cs, arg_types, res_type) = splitHsFunType body_ty + in (PrefixConGADT arg_types, res_type, anns, cs) + + an = case outer_bndrs of + _ -> ApiAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa) - pure ( ConDeclGADT { con_g_ext = noExtField + pure $ L l ConDeclGADT + { con_g_ext = an , con_names = names , con_bndrs = L (getLoc ty) outer_bndrs , con_mb_cxt = mcxt , con_g_args = args , con_res_ty = res_ty , con_doc = Nothing } - , anns ) where (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty @@ -743,34 +823,39 @@ eitherToP :: MonadP m => Either PsError a -> m a eitherToP (Left err) = addFatalError err eitherToP (Right thing) = return thing -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] +checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs] -> P ( LHsQTyVars GhcPs -- the synthesized type variables - , [AddAnn] ) -- action which adds annotations + , [AddApiAnn] ) -- action which adds annotations -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where - check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc - check (HsValArg ty) = chkParens [] ty + check :: HsArg (LHsType GhcPs) (LHsType GhcPs) -> P (LHsTyVarBndr () GhcPs, [AddApiAnn]) -- AZ + check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc) + check (HsValArg ty) = chkParens [] noCom ty check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp -- Keep around an action for adjusting the annotations of extra parens - chkParens :: [AddAnn] -> LHsType GhcPs - -> P (LHsTyVarBndr () GhcPs, [AddAnn]) - chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty - chkParens acc ty = do - tv <- chk ty + chkParens :: [AddApiAnn] -> ApiAnnComments -> LHsType GhcPs + -> P (LHsTyVarBndr () GhcPs, [AddApiAnn]) + chkParens acc cs (L l (HsParTy an ty)) + = chkParens (mkParensApiAnn (locA l) ++ acc) (cs Semi.<> apiAnnComments an) ty + chkParens acc cs ty = do + tv <- chk acc cs ty return (tv, reverse acc) -- Check that the name space is correct! - chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) - chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) - | isRdrTyVar tv = return (L l (KindedTyVar noExtField () (L lv tv) k)) - chk (L l (HsTyVar _ _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar noExtField () (L ltv tv))) - chk t@(L loc _) - = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc + chk :: [AddApiAnn] -> ApiAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) + chk an cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k)) + | isRdrTyVar tv + = return (L (widenLocatedAn (l Semi.<> annt) an) + (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k)) + chk an cs (L l (HsTyVar ann _ (L ltv tv))) + | isRdrTyVar tv = return (L (widenLocatedAn l an) + (UserTyVar (addAnns ann an cs) () (L ltv tv))) + chk _ _ t@(L loc _) + = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc) whereDots, equalsDots :: SDoc @@ -782,26 +867,26 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit - unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLoc c) + unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c) type LRuleTyTmVar = Located RuleTyTmVar -data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) +data RuleTyTmVar = RuleTyTmVar ApiAnn (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ -- turns RuleTyTmVars into RuleBnrs - this is straightforward mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] mkRuleBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExtField v - cvt_one (RuleTyTmVar v (Just sig)) = - RuleBndrSig noExtField v (mkHsPatSigType sig) + where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v + cvt_one (RuleTyTmVar ann v (Just sig)) = + RuleBndrSig ann v (mkHsPatSigType sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] -mkRuleTyVarBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) - = UserTyVar noExtField () (fmap tm_to_ty v) - cvt_one (RuleTyTmVar v (Just sig)) - = KindedTyVar noExtField () (fmap tm_to_ty v) sig +mkRuleTyVarBndrs = fmap cvt_one + where cvt_one (L l (RuleTyTmVar ann v Nothing)) + = L (noAnnSrcSpan l) (UserTyVar ann () (fmap tm_to_ty v)) + cvt_one (L l (RuleTyTmVar ann v (Just sig))) + = L (noAnnSrcSpan l) (KindedTyVar ann () (fmap tm_to_ty v) sig) -- takes something in namespace 'varName' to something in namespace 'tvName' tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) tm_to_ty _ = panic "mkRuleTyVarBndrs" @@ -812,19 +897,19 @@ checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"]) - (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] loc) + (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc)) check _ = panic "checkRuleTyVarBndrNames" -checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) +checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit - unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] loc + unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc) return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for -- `data T where` to avoid affecting existing error message, see #8258. -checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) - -> P (Located ([AddAnn], [LConDecl GhcPs])) +checkEmptyGADTs :: Located ([AddApiAnn], [LConDecl GhcPs]) + -> P (Located ([AddApiAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span @@ -834,10 +919,11 @@ checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. checkTyClHdr :: Bool -- True <=> class header -- False <=> type header -> LHsType GhcPs - -> P (Located RdrName, -- the head symbol (type or class name) - [LHsTypeArg GhcPs], -- parameters of head symbol + -> P (LocatedN RdrName, -- the head symbol (type or class name) + [LHsTypeArg GhcPs], -- parameters of head symbol LexicalFixity, -- the declaration is in infix format - [AddAnn]) -- API Annotation for HsParTy when stripping parens + [AddApiAnn]) -- API Annotation for HsParTy + -- when stripping parens -- Well-formedness check and decomposition of type and class heads. -- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) -- Int :*: Bool into (:*:, [Int, Bool]) @@ -845,13 +931,15 @@ checkTyClHdr :: Bool -- True <=> class header checkTyClHdr is_cls ty = goL ty [] [] Prefix where - goL (L l ty) acc ann fix = go l ty acc ann fix + goL (L l ty) acc ann fix = go (locA l) ty acc ann fix -- workaround to define '*' despite StarIsType - go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix - = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder l) + go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ann' fix + = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l)) ; let name = mkOccName tcClsName (starSym isUni) - ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } + ; let a' = newAnns l an + ; return (L a' (Unqual name), acc, fix + , ann') } go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix | isRdrTc tc = return (ltc, acc, fix, ann) @@ -861,7 +949,8 @@ checkTyClHdr is_cls ty go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann) + = return (L (noAnnSrcSpan l) (nameRdrName tup_name) + , map HsValArg ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity @@ -870,6 +959,22 @@ checkTyClHdr is_cls ty go l _ _ _ _ = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l + -- Combine the annotations from the HsParTy and HsStarTy into a + -- new one for the LocatedN RdrName + newAnns :: SrcSpanAnnA -> ApiAnn' AnnParen -> SrcSpanAnnN + newAnns (SrcSpanAnn ApiAnnNotUsed l) (ApiAnn as (AnnParen _ o c) cs) = + let + lr = combineRealSrcSpans (realSrcSpan l) (anchor as) + -- lr = widenAnchorR as (realSrcSpan l) + an = (ApiAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (AR $ realSrcSpan l) c []) cs) + in SrcSpanAnn an (RealSrcSpan lr Nothing) + newAnns _ ApiAnnNotUsed = panic "missing AnnParen" + newAnns (SrcSpanAnn (ApiAnn ap (AnnListItem ta) csp) l) (ApiAnn as (AnnParen _ o c) cs) = + let + lr = combineRealSrcSpans (anchor ap) (anchor as) + an = (ApiAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (AR $ realSrcSpan l) c ta) (csp Semi.<> cs)) + in SrcSpanAnn an (RealSrcSpan lr Nothing) + -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled. checkExpBlockArguments :: LHsExpr GhcPs -> PV () @@ -900,7 +1005,7 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () check err a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $ - addError $ PsError (err a) [] (getLoc a) + addError $ PsError (err a) [] (getLocA a) -- | Validate the context constraints and break up a context into a list -- of predicates. @@ -911,26 +1016,37 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () -- (Eq a) --> [Eq a] -- (((Eq a))) --> [Eq a] -- @ -checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) -checkContext (L l orig_t) - = check [] (L l orig_t) +checkContext :: LHsType GhcPs -> P (LHsContext GhcPs) +checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) = + check ([],[],noCom) orig_t where - check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + check :: ([AnnAnchor],[AnnAnchor],ApiAnnComments) + -> LHsType GhcPs -> P (LHsContext GhcPs) + check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can -- be used as context constraints. - = return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto () - - check anns (L lp1 (HsParTy _ ty)) + -- Ditto () + = do + let (op,cp,cs') = case ann' of + ApiAnnNotUsed -> ([],[],noCom) + ApiAnn _ (AnnParen _ o c) cs -> ([o],[c],cs) + return (L (SrcSpanAnn (ApiAnn (spanAsAnchor l) + (AnnContext Nothing (op Semi.<> oparens) (cp Semi.<> cparens)) (cs Semi.<> cs')) l) ts) + + check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty)) -- to be sure HsParTy doesn't get into the way - = check anns' ty - where anns' = if l == lp1 then anns - else (anns ++ mkParensApiAnn lp1) - - -- no need for anns, returning original - check _anns _t = return ([],L l [L l orig_t]) - -checkImportDecl :: Maybe (Located Token) - -> Maybe (Located Token) + = do + let (op,cp,cs') = case ann' of + ApiAnnNotUsed -> ([],[],noCom) + ApiAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs) + check (op++opi,cp++cpi,cs' Semi.<> csi) ty + + -- No need for anns, returning original + check (_opi,_cpi,_csi) _t = + return (L (SrcSpanAnn (ApiAnn (spanAsAnchor l) (AnnContext Nothing [] []) noCom) l) [orig_t]) + +checkImportDecl :: Maybe AnnAnchor + -> Maybe AnnAnchor -> P () checkImportDecl mPre mPost = do let whenJust mg f = maybe (pure ()) f mg @@ -941,18 +1057,18 @@ checkImportDecl mPre mPost = do -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $ - failOpNotEnabledImportQualifiedPost (getLoc post) + failOpNotEnabledImportQualifiedPost (RealSrcSpan (annAnchorRealSrcSpan post) Nothing) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $ - failOpImportQualifiedTwice (getLoc post) + failOpImportQualifiedTwice (RealSrcSpan (annAnchorRealSrcSpan post) Nothing) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. whenJust mPre $ \pre -> - warnPrepositiveQualifiedModule (getLoc pre) + warnPrepositiveQualifiedModule (RealSrcSpan (annAnchorRealSrcSpan pre) Nothing) -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -960,40 +1076,40 @@ checkImportDecl mPre mPost = do -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) +checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [Hint] -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat) -checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) +checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] -checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] +checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] -> PV (LPat GhcPs) -checkPat loc (L l e@(PatBuilderVar (L _ c))) tyargs args +checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args | isRdrDataCon c = return . L loc $ ConPat - { pat_con_ext = noExtField - , pat_con = L l c + { pat_con_ext = noAnn -- AZ: where should this come from? + , pat_con = L ln c , pat_args = PrefixCon tyargs args } | not (null tyargs) = add_hint TypeApplicationsInPatternsOnlyDataCons $ - patFail l (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) + patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) | not (null args) && patIsRec c = add_hint SuggestRecursiveDo $ - patFail l (ppr e) -checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = + patFail (locA l) (ppr e) +checkPat loc (L _ (PatBuilderAppType f _ t)) tyargs args = checkPat loc f (t : tyargs) args checkPat loc (L _ (PatBuilderApp f e)) [] args = do p <- checkLPat e checkPat loc f [] (p : args) -checkPat loc (L _ e) [] [] = do +checkPat loc (L l e) [] [] = do p <- checkAPat loc e - return (L loc p) -checkPat loc e _ _ = patFail loc (ppr e) + return (L l p) +checkPat loc e _ _ = patFail (locA loc) (ppr e) -checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs) +checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) checkAPat loc e0 = do nPlusKPatterns <- getBit NPlusKPatternsBit case e0 of @@ -1003,45 +1119,50 @@ checkAPat loc e0 = do -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve -- NB. Negative *primitive* literals are already handled by the lexer - PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing) + PatBuilderOverLit pos_lit -> return (mkNPat (L (locA loc) pos_lit) Nothing noAnn) -- n+k patterns PatBuilderOpApp - (L nloc (PatBuilderVar (L _ n))) + (L _ (PatBuilderVar (L nloc n))) (L _ plus) (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | nPlusKPatterns && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) (L lloc lit)) + anns + | nPlusKPatterns && (plus == plus_RDR) + -> return (mkNPlusKPat (L nloc n) (L (locA lloc) lit) anns) -- Improve error messages for the @-operator when the user meant an @-pattern - PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do - addError $ PsError PsErrAtInPatPos [] (getLoc op) + PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do + addError $ PsError PsErrAtInPatPos [] (getLocA op) return (WildPat noExtField) - PatBuilderOpApp l (L cl c) r + PatBuilderOpApp l (L cl c) r anns | isRdrDataCon c -> do l <- checkLPat l r <- checkLPat r return $ ConPat - { pat_con_ext = noExtField + { pat_con_ext = anns , pat_con = L cl c , pat_args = InfixCon l r } - PatBuilderPar e -> checkLPat e >>= (return . (ParPat noExtField)) - _ -> patFail loc (ppr e0) + PatBuilderPar e an@(AnnParen pt o c) -> do + (L l p) <- checkLPat e + let aa = [AddApiAnn ai o, AddApiAnn ac c] + (ai,ac) = parenTypeKws pt + return (ParPat (ApiAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an noCom) (L l p)) + _ -> patFail (locA loc) (ppr e0) -placeHolderPunRhs :: DisambECP b => PV (Located b) +placeHolderPunRhs :: DisambECP b => PV (LocatedA b) -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when -- debugging -placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR) +placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR) plus_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs)) +checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) -> PV (LHsRecField GhcPs (LPat GhcPs)) checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld) return (L l (fld { hsRecFieldArg = p })) @@ -1055,47 +1176,49 @@ patIsRec e = e == mkUnqual varName (fsLit "rec") --------------------------------------------------------------------------- -- Check Equation Syntax -checkValDef :: Located (PatBuilder GhcPs) - -> Maybe (LHsType GhcPs) - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) +checkValDef :: SrcSpan + -> LocatedA (PatBuilder GhcPs) + -> Maybe (AddApiAnn, LHsType GhcPs) + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) -checkValDef lhs (Just sig) grhss +checkValDef loc lhs (Just (sigAnn, sig)) grhss -- x :: ty = rhs parses as a *pattern* binding - = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat - checkPatBind lhs' grhss + = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn] + >>= checkLPat + checkPatBind loc [] lhs' grhss -checkValDef lhs Nothing g@(L l (_,grhss)) +checkValDef loc lhs Nothing g@(L l grhss) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats, ann) -> - checkFunBind NoSrcStrict ann (getLoc lhs) + checkFunBind NoSrcStrict loc ann (getLocA lhs) fun is_infix pats (L l grhss) Nothing -> do lhs' <- checkPattern lhs - checkPatBind lhs' g } + checkPatBind loc [] lhs' g } checkFunBind :: SrcStrictness - -> [AddAnn] -> SrcSpan - -> Located RdrName + -> [AddApiAnn] + -> SrcSpan + -> LocatedN RdrName -> LexicalFixity - -> [Located (PatBuilder GhcPs)] + -> [LocatedA (PatBuilder GhcPs)] -> Located (GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) -checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) + -> P (HsBind GhcPs) +checkFunBind strictness locF ann lhs_loc fun is_infix pats (L rhs_span grhss) = do ps <- runPV_hints param_hints (mapM checkLPat pats) - let match_span = combineSrcSpans lhs_loc rhs_span - -- Add back the annotations stripped from any HsPar values in the lhs - -- mapM_ (\a -> a match_span) ann - return (ann, makeFunBind fun - [L match_span (Match { m_ext = noExtField - , m_ctxt = FunRhs - { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })]) + let match_span = noAnnSrcSpan $ combineSrcSpans lhs_loc rhs_span + cs <- getCommentsFor locF + return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) + [L match_span (Match { m_ext = ApiAnn (spanAsAnchor locF) ann cs + , m_ctxt = FunRhs + { mc_fun = fun + , mc_fixity = is_infix + , mc_strictness = strictness } + , m_pats = ps + , m_grhss = grhss })])) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. where @@ -1103,7 +1226,7 @@ checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)] | otherwise = [] -makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] +makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms @@ -1113,62 +1236,66 @@ makeFunBind fn ms fun_tick = [] } -- See Note [FunBind vs PatBind] -checkPatBind :: LPat GhcPs - -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) - -> P ([AddAnn],HsBind GhcPs) -checkPatBind lhs (L rhs_span (_,grhss)) - | BangPat _ p <- unLoc lhs - , VarPat _ v <- unLoc p - = return ([], makeFunBind v [L match_span (m v)]) +checkPatBind :: SrcSpan + -> [AddApiAnn] + -> LPat GhcPs + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) +checkPatBind loc annsIn (L _ (BangPat (ApiAnn _ ans cs) (L _ (VarPat _ v)))) + (L _match_span grhss) + = return (makeFunBind v (L (noAnnSrcSpan loc) + [L (noAnnSrcSpan loc) (m (ApiAnn (spanAsAnchor loc) (ans++annsIn) cs) v)])) where - match_span = combineSrcSpans (getLoc lhs) rhs_span - m v = Match { m_ext = noExtField - , m_ctxt = FunRhs { mc_fun = v - , mc_fixity = Prefix - , mc_strictness = SrcStrict } - , m_pats = [] - , m_grhss = grhss } - -checkPatBind lhs (L _ (_,grhss)) - = return ([],PatBind noExtField lhs grhss ([],[])) - -checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) + m a v = Match { m_ext = a + , m_ctxt = FunRhs { mc_fun = v + , mc_fixity = Prefix + , mc_strictness = SrcStrict } + , m_pats = [] + , m_grhss = grhss } + +checkPatBind loc annsIn lhs (L _ grhss) = do + cs <- getCommentsFor loc + return (PatBind (ApiAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[])) + +checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) | isUnqual v , not (isDataOcc (rdrNameOcc v)) = return lrdr checkValSigLhs lhs@(L l _) - = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] l + = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l) checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c) => (a -> Bool -> b -> Bool -> c -> PsErrorDesc) - -> Located a -> Bool -> Located b -> Bool -> Located c -> PV () + -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr | semiThen || semiElse = do doAndIfThenElse <- getBit DoAndIfThenElseBit let e = err (unLoc guardExpr) semiThen (unLoc thenExpr) semiElse (unLoc elseExpr) - loc = combineLocs guardExpr elseExpr + loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) unless doAndIfThenElse $ addError (PsError e [] loc) | otherwise = return () -isFunLhs :: Located (PatBuilder GhcPs) - -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) +isFunLhs :: LocatedA (PatBuilder GhcPs) + -> P (Maybe (LocatedN RdrName, LexicalFixity, + [LocatedA (PatBuilder GhcPs)],[AddApiAnn])) -- A variable binding is parsed as a FunBind. -- Just (fun, is_infix, arg_pats) if e is a function LHS isFunLhs e = go e [] [] where - go (L loc (PatBuilderVar (L _ f))) es ann + go (L _ (PatBuilderVar (L loc f))) es ann | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) go (L _ (PatBuilderApp f e)) es ann = go f (e:es) ann - go (L l (PatBuilderPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) - go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann + go (L l (PatBuilderPar e _an)) es@(_:_) ann + = go e es (ann ++ mkParensApiAnn (locA l)) + go (L loc (PatBuilderOpApp l (L loc' op) r (ApiAnn loca anns cs))) es ann | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), ann)) + = return (Just (L loc' op, Infix, (l:r:es), (anns ++ ann))) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of @@ -1176,35 +1303,36 @@ isFunLhs e = go e [] [] -> return (Just (op', Infix, j : op_app : es', ann')) where op_app = L loc (PatBuilderOpApp k - (L loc' op) r) + (L loc' op) r (ApiAnn loca anns cs)) _ -> return Nothing } go _ _ _ = return Nothing -mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs -mkBangTy strictness = - HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness) +mkBangTy :: ApiAnn -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy anns strictness = + HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness) -- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@. data UnpackednessPragma = - UnpackednessPragma [AddAnn] SourceText SrcUnpackedness + UnpackednessPragma [AddApiAnn] SourceText SrcUnpackedness -- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma. addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs) addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do - let l' = combineSrcSpans lprag (getLoc ty) - t' = addUnpackedness ty - addAnnsAt l' anns - return (L l' t') + let l' = combineSrcSpans lprag (getLocA ty) + cs <- getCommentsFor l' + let an = ApiAnn (spanAsAnchor l') anns cs + t' = addUnpackedness an ty + return (L (noAnnSrcSpan l') t') where -- If we have a HsBangTy that only has a strictness annotation, -- such as ~T or !T, then add the pragma to the existing HsBangTy. -- -- Otherwise, wrap the type in a new HsBangTy constructor. - addUnpackedness (L _ (HsBangTy x bang t)) + addUnpackedness an (L _ (HsBangTy x bang t)) | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang - = HsBangTy x (HsSrcBang prag unpk strictness) t - addUnpackedness t - = HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t + = HsBangTy (addAnns an (apiAnnAnns x) (apiAnnComments x)) (HsSrcBang prag unpk strictness) t + addUnpackedness an t + = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t --------------------------------------------------------------------------- -- | Check for monad comprehensions @@ -1237,7 +1365,7 @@ checkMonadComp = do -- P (forall b. DisambECP b => PV (Located b)) -- newtype ECP = - ECP { unECP :: forall b. DisambECP b => PV (Located b) } + ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) } ecpFromExp :: LHsExpr GhcPs -> ECP ecpFromExp a = ECP (ecpFromExp' a) @@ -1247,79 +1375,98 @@ ecpFromCmd a = ECP (ecpFromCmd' a) -- The 'fbinds' parser rule produces values of this type. See Note -- [RecordDotSyntax field updates]. -type Fbind b = Either (LHsRecField GhcPs (Located b)) (LHsRecProj GhcPs (Located b)) +type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b)) -- | Disambiguate infix operators. -- See Note [Ambiguous syntactic categories] class DisambInfixOp b where - mkHsVarOpPV :: Located RdrName -> PV (Located b) - mkHsConOpPV :: Located RdrName -> PV (Located b) - mkHsInfixHolePV :: SrcSpan -> PV (Located b) + mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsInfixHolePV :: SrcSpan -> (ApiAnnComments -> ApiAnn' ApiAnnUnboundVar) -> PV (Located b) instance DisambInfixOp (HsExpr GhcPs) where mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) - mkHsInfixHolePV l = return $ L l hsHoleExpr + mkHsInfixHolePV l ann = do + cs <- getCommentsFor l + return $ L l (hsHoleExpr (ann cs)) instance DisambInfixOp RdrName where mkHsConOpPV (L l v) = return $ L l v mkHsVarOpPV (L l v) = return $ L l v - mkHsInfixHolePV l = addFatalError $ PsError PsErrInvalidInfixHole [] l + mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l + +type AnnoBody b + = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan + , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL + , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA + , Anno [LocatedA (StmtLR GhcPs GhcPs + (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL + ) -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are -- parsing an expression, a command, or a pattern. -- See Note [Ambiguous syntactic categories] -class b ~ (Body b) GhcPs => DisambECP b where +class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | See Note [Body in DisambECP] type Body b :: Type -> Type -- | Return a command without ambiguity, or fail in a non-command context. - ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b) + ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b) -- | Return an expression without ambiguity, or fail in a non-expression context. - ecpFromExp' :: LHsExpr GhcPs -> PV (Located b) - -- | This can only be satified by expressions. - mkHsProjUpdatePV :: SrcSpan -> Located [Located FieldLabelString] -> Located b -> Bool -> PV (LHsRecProj GhcPs (Located b)) + ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b) + mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)] + -> LocatedA b -> Bool -> [AddApiAnn] -> PV (LHsRecProj GhcPs (LocatedA b)) -- | Disambiguate "\... -> ..." (lambda) - mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) + mkHsLamPV + :: SrcSpan -> (ApiAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b) -- | Disambiguate "let ... in ..." - mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b) + mkHsLetPV + :: SrcSpan -> HsLocalBinds GhcPs -> LocatedA b -> AnnsLet -> PV (LocatedA b) -- | Infix operator representation type InfixOp b -- | Bring superclass constraints on InfixOp into scope. -- See Note [UndecidableSuperClasses for associated types] - superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b) + superInfixOp + :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b) -- | Disambiguate "f # x" (infix operator) - mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b) + mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b + -> PV (LocatedA b) -- | Disambiguate "case ... of ..." - mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b) - -- | Disambiguate @\\case ...@ (lambda case) - mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b) + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)]) + -> ApiAnnHsCase -> PV (LocatedA b) + mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)]) + -> [AddApiAnn] + -> PV (LocatedA b) -- | Function argument representation type FunArg b -- | Bring superclass constraints on FunArg into scope. -- See Note [UndecidableSuperClasses for associated types] - superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b) + superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b) -- | Disambiguate "f x" (function application) - mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b) + mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b) -- | Disambiguate "f @t" (visible type application) - mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate "if ... then ... else ..." mkHsIfPV :: SrcSpan -> LHsExpr GhcPs -> Bool -- semicolon? - -> Located b + -> LocatedA b -> Bool -- semicolon? - -> Located b - -> PV (Located b) + -> LocatedA b + -> [AddApiAnn] + -> PV (LocatedA b) -- | Disambiguate "do { ... }" (do notation) mkHsDoPV :: SrcSpan -> Maybe ModuleName -> - Located [LStmt GhcPs (Located b)] -> - PV (Located b) + LocatedL [LStmt GhcPs (LocatedA b)] -> + AnnList -> + PV (LocatedA b) -- | Disambiguate "( ... )" (parentheses) - mkHsParPV :: SrcSpan -> Located b -> PV (Located b) + mkHsParPV :: SrcSpan -> LocatedA b -> AnnParen -> PV (LocatedA b) -- | Disambiguate a variable "f" or a data constructor "MkF". - mkHsVarPV :: Located RdrName -> PV (Located b) + mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) -- | Disambiguate a monomorphic literal mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) -- | Disambiguate an overloaded literal @@ -1327,9 +1474,10 @@ class b ~ (Body b) GhcPs => DisambECP b where -- | Disambiguate a wildcard mkHsWildCardPV :: SrcSpan -> PV (Located b) -- | Disambiguate "a :: t" (type annotation) - mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b) + mkHsTySigPV + :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) @@ -1337,25 +1485,30 @@ class b ~ (Body b) GhcPs => DisambECP b where Bool -> -- Is OverloadedRecordUpdate in effect? SrcSpan -> SrcSpan -> - Located b -> + LocatedA b -> ([Fbind b], Maybe SrcSpan) -> - PV (Located b) + [AddApiAnn] -> + PV (LocatedA b) -- | Disambiguate "-a" (negation) - mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b) + mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "(# a)" (right operator section) - mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b) + mkHsSectionR_PV + :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b) -- | Disambiguate "(a -> b)" (view pattern) - mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b) + mkHsViewPatPV + :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "a@b" (as-pattern) - mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b) + mkHsAsPatPV + :: SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "~a" (lazy pattern) - mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b) + mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate "!a" (bang pattern) - mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b) + mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddApiAnn] -> PV (LocatedA b) -- | Disambiguate tuple sections and unboxed sums - mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b) + mkSumOrTuplePV + :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddApiAnn] -> PV (LocatedA b) -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas - rejectPragmaPV :: Located b -> PV () + rejectPragmaPV :: LocatedA b -> PV () {- Note [UndecidableSuperClasses for associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1404,57 +1557,74 @@ typechecker. instance DisambECP (HsCmd GhcPs) where type Body (HsCmd GhcPs) = HsCmd ecpFromCmd' = return - ecpFromExp' (L l e) = cmdFail l (ppr e) - mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l - mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg) - mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e) + ecpFromExp' (L l e) = cmdFail (locA l) (ppr e) + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + mkHsLamPV l mg = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs)) + mkHsLetPV l bs e anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdLet (ApiAnn (spanAsAnchor l) anns cs) bs e) type InfixOp (HsCmd GhcPs) = HsExpr GhcPs superInfixOp m = m mkHsOpAppPV l c1 op c2 = do - let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c - return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2] - mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg) - mkHsLamCasePV l mg = return $ L l (HsCmdLamCase noExtField mg) + let cmdArg c = L (getLocA c) $ HsCmdTop noExtField c + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) $ HsCmdArrForm (ApiAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2] + mkHsCasePV l c (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsCmdCase (ApiAnn (spanAsAnchor l) anns cs) c mg) + mkHsLamCasePV l (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsCmdLamCase (ApiAnn (spanAsAnchor l) anns cs) mg) type FunArg (HsCmd GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l c e = do + cs <- getCommentsFor (locA l) checkCmdBlockArguments c checkExpBlockArguments e - return $ L l (HsCmdApp noExtField c e) - mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t) - mkHsIfPV l c semi1 a semi2 b = do + return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e) + mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t) + mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b - return $ L l (mkHsCmdIf c a b) - mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts) - mkHsDoPV l (Just m) _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l - mkHsParPV l c = return $ L l (HsCmdPar noExtField c) - mkHsVarPV (L l v) = cmdFail l (ppr v) + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (ApiAnn (spanAsAnchor l) anns cs)) + mkHsDoPV l Nothing stmts anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdDo (ApiAnn (spanAsAnchor l) anns cs) stmts) + mkHsDoPV l (Just m) _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l + mkHsParPV l c ann = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsCmdPar (ApiAnn (spanAsAnchor l) ann cs) c) + mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a) mkHsOverLitPV (L l a) = cmdFail l (ppr a) mkHsWildCardPV l = cmdFail l (text "_") - mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig) - mkHsExplicitListPV l xs = cmdFail l $ + mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig) + mkHsExplicitListPV l xs _ = cmdFail l $ brackets (fsep (punctuate comma (map ppr xs))) mkHsSplicePV (L l sp) = cmdFail l (ppr sp) - mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do let (fs, ps) = partitionEithers fbinds if not (null ps) then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) - mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a) + mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) mkHsSectionR_PV l op c = cmdFail l $ let pp_op = fromMaybe (panic "cannot print infix operator") (ppr_infix_expr (unLoc op)) in pp_op <> ppr c - mkHsViewPatPV l a b = cmdFail l $ + mkHsViewPatPV l a b _ = cmdFail l $ ppr a <+> text "->" <+> ppr b - mkHsAsPatPV l v c = cmdFail l $ + mkHsAsPatPV l v c _ = cmdFail l $ pprPrefixOcc (unLoc v) <> text "@" <> ppr c - mkHsLazyPatPV l c = cmdFail l $ + mkHsLazyPatPV l c _ = cmdFail l $ text "~" <> ppr c - mkHsBangPatPV l c = cmdFail l $ + mkHsBangPatPV l c _ = cmdFail l $ text "!" <> ppr c - mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a) + mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a) rejectPragmaPV _ = return () cmdFail :: SrcSpan -> SDoc -> PV a @@ -1463,121 +1633,172 @@ cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc instance DisambECP (HsExpr GhcPs) where type Body (HsExpr GhcPs) = HsExpr ecpFromCmd' (L l c) = do - addError $ PsError (PsErrArrowCmdInExpr c) [] l - return (L l hsHoleExpr) + addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l) + return (L l (hsHoleExpr noAnn)) ecpFromExp' = return - mkHsProjUpdatePV l fields arg isPun = return $ mkRdrProjUpdate l fields arg isPun - mkHsLamPV l mg = return $ L l (HsLam noExtField mg) - mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) + mkHsProjUpdatePV l fields arg isPun anns = do + cs <- getCommentsFor l + return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (ApiAnn (spanAsAnchor l) anns cs) + mkHsLamPV l mg = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsLam NoExtField (mg cs)) + mkHsLetPV l bs c anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsLet (ApiAnn (spanAsAnchor l) anns cs) bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m - mkHsOpAppPV l e1 op e2 = - return $ L l $ OpApp noExtField e1 op e2 - mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg) - mkHsLamCasePV l mg = return $ L l (HsLamCase noExtField mg) + mkHsOpAppPV l e1 op e2 = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) $ OpApp (ApiAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2 + mkHsCasePV l e (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsCase (ApiAnn (spanAsAnchor l) anns cs) e mg) + mkHsLamCasePV l (L lm m) anns = do + cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (noAnnSrcSpan l) (HsLamCase (ApiAnn (spanAsAnchor l) anns cs) mg) type FunArg (HsExpr GhcPs) = HsExpr GhcPs superFunArg m = m mkHsAppPV l e1 e2 = do + cs <- getCommentsFor (locA l) checkExpBlockArguments e1 checkExpBlockArguments e2 - return $ L l (HsApp noExtField e1 e2) - mkHsAppTypePV l e t = do + return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2) + mkHsAppTypePV l e la t = do checkExpBlockArguments e - return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t)) - mkHsIfPV l c semi1 a semi2 b = do + return $ L l (HsAppType la e (mkHsWildCardBndrs t)) + mkHsIfPV l c semi1 a semi2 b anns = do checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b - return $ L l (mkHsIf c a b) - mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts) - mkHsParPV l e = return $ L l (HsPar noExtField e) - mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v) - mkHsLitPV (L l a) = return $ L l (HsLit noExtField a) - mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a) - mkHsWildCardPV l = return $ L l hsHoleExpr - mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (hsTypeToHsSigWcType sig)) - mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField xs) - mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp - mkHsRecordPV opts l lrec a (fbinds, ddLoc) = do - r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) - checkRecordSyntax (L l r) - mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) - mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e) - mkHsViewPatPV l a b = addError (PsError (PsErrViewPatInExpr a b) [] l) - >> return (L l hsHoleExpr) - mkHsAsPatPV l v e = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l) - >> return (L l hsHoleExpr) - mkHsLazyPatPV l e = addError (PsError (PsErrLazyPatWithoutSpace e) [] l) - >> return (L l hsHoleExpr) - mkHsBangPatPV l e = addError (PsError (PsErrBangPatWithoutSpace e) [] l) - >> return (L l hsHoleExpr) + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (mkHsIf c a b (ApiAnn (spanAsAnchor l) anns cs)) + mkHsDoPV l mod stmts anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsDo (ApiAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts) + mkHsParPV l e ann = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (HsPar (ApiAnn (spanAsAnchor l) ann cs) e) + mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v) + mkHsLitPV (L l a) = do + cs <- getCommentsFor l + return $ L l (HsLit (comment (realSrcSpan l) cs) a) + mkHsOverLitPV (L l a) = do + cs <- getCommentsFor l + return $ L l (HsOverLit (comment (realSrcSpan l) cs) a) + mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn) + mkHsTySigPV l a sig anns = do + cs <- getCommentsFor (locA l) + return $ L l (ExprWithTySig (ApiAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig)) + mkHsExplicitListPV l xs anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (ExplicitList (ApiAnn (spanAsAnchor l) anns cs) xs) + mkHsSplicePV sp@(L l _) = do + cs <- getCommentsFor l + return $ mapLoc (HsSpliceE (ApiAnn (spanAsAnchor l) NoApiAnns cs)) sp + mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do + cs <- getCommentsFor l + r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (ApiAnn (spanAsAnchor l) anns cs) + checkRecordSyntax (L (noAnnSrcSpan l) r) + mkHsNegAppPV l a anns = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (NegApp (ApiAnn (spanAsAnchor l) anns cs) a noSyntaxExpr) + mkHsSectionR_PV l op e = do + cs <- getCommentsFor l + return $ L l (SectionR (comment (realSrcSpan l) cs) op e) + mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) + mkHsAsPatPV l v e _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) + mkHsLazyPatPV l e _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) + mkHsBangPatPV l e _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l) + >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) mkSumOrTuplePV = mkSumOrTupleExpr rejectPragmaPV (L _ (OpApp _ _ _ e)) = -- assuming left-associative parsing of operators rejectPragmaPV e - rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] l + rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l) rejectPragmaPV _ = return () -hsHoleExpr :: HsExpr GhcPs -hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") +hsHoleExpr :: ApiAnn' ApiAnnUnboundVar -> HsExpr GhcPs +hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") + +type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpan +type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL +type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA +type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] l - ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] l + ecpFromCmd' (L l c) = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l) + ecpFromExp' (L l e) = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l) mkHsLamPV l _ = addFatalError $ PsError PsErrLambdaInPat [] l - mkHsLetPV l _ _ = addFatalError $ PsError PsErrLetInPat [] l - mkHsProjUpdatePV l _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l + mkHsLetPV l _ _ _ = addFatalError $ PsError PsErrLetInPat [] l + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m - mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2 - mkHsCasePV l _ _ = addFatalError $ PsError PsErrCaseInPat [] l - mkHsLamCasePV l _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l + mkHsOpAppPV l p1 op p2 = do + cs <- getCommentsFor l + let anns = ApiAnn (spanAsAnchor l) [] cs + return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns + mkHsCasePV l _ _ _ = addFatalError $ PsError PsErrCaseInPat [] l + mkHsLamCasePV l _ _ = addFatalError $ PsError PsErrLambdaCaseInPat [] l type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m - mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) - mkHsAppTypePV l p t = return $ L l (PatBuilderAppType p (mkHsPatSigType t)) - mkHsIfPV l _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l - mkHsDoPV l _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l - mkHsParPV l p = return $ L l (PatBuilderPar p) - mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) + mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) + mkHsAppTypePV l p la t = return $ L l (PatBuilderAppType p la (mkHsPatSigType t)) + mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l + mkHsDoPV l _ _ _ = addFatalError $ PsError PsErrDoNotationInPat [] l + mkHsParPV l p an = return $ L (noAnnSrcSpan l) (PatBuilderPar p an) + mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do checkUnboxedStringLitPat lit return $ L l (PatBuilderPat (LitPat noExtField a)) mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) - mkHsTySigPV l b sig = do + mkHsTySigPV l b sig anns = do p <- checkLPat b - return $ L l (PatBuilderPat (SigPat noExtField p (mkHsPatSigType sig))) - mkHsExplicitListPV l xs = do + cs <- getCommentsFor (locA l) + return $ L l (PatBuilderPat (SigPat (ApiAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType sig))) + mkHsExplicitListPV l xs anns = do ps <- traverse checkLPat xs - return (L l (PatBuilderPat (ListPat noExtField ps))) + cs <- getCommentsFor l + return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (ApiAnn (spanAsAnchor l) anns cs) ps))) mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) - mkHsRecordPV _ l _ a (fbinds, ddLoc) = do + mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do let (fs, ps) = partitionEithers fbinds if not (null ps) then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l else do - r <- mkPatRec a (mk_rec_fields fs ddLoc) - checkRecordSyntax (L l r) - mkHsNegAppPV l (L lp p) = do + cs <- getCommentsFor l + r <- mkPatRec a (mk_rec_fields fs ddLoc) (ApiAnn (spanAsAnchor l) anns cs) + checkRecordSyntax (L (noAnnSrcSpan l) r) + mkHsNegAppPV l (L lp p) anns = do lit <- case p of - PatBuilderOverLit pos_lit -> return (L lp pos_lit) + PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit) _ -> patFail l (text "-" <> ppr p) - return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr))) + cs <- getCommentsFor l + let an = ApiAnn (spanAsAnchor l) anns cs + return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an)) mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p) - mkHsViewPatPV l a b = do + mkHsViewPatPV l a b anns = do p <- checkLPat b - return $ L l (PatBuilderPat (ViewPat noExtField a p)) - mkHsAsPatPV l v e = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (ApiAnn (spanAsAnchor l) anns cs) a p)) + mkHsAsPatPV l v e a = do p <- checkLPat e - return $ L l (PatBuilderPat (AsPat noExtField v p)) - mkHsLazyPatPV l e = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (ApiAnn (spanAsAnchor l) a cs) v p)) + mkHsLazyPatPV l e a = do p <- checkLPat e - return $ L l (PatBuilderPat (LazyPat noExtField p)) - mkHsBangPatPV l e = do + cs <- getCommentsFor l + return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (ApiAnn (spanAsAnchor l) a cs) p)) + mkHsBangPatPV l e an = do p <- checkLPat e - let pb = BangPat noExtField p + cs <- getCommentsFor l + let pb = BangPat (ApiAnn (spanAsAnchor l) an cs) p hintBangPat l pb - return $ L l (PatBuilderPat pb) + return $ L (noAnnSrcSpan l) (PatBuilderPat pb) mkSumOrTuplePV = mkSumOrTuplePat rejectPragmaPV _ = return () @@ -1589,19 +1810,20 @@ checkUnboxedStringLitPat (L loc lit) = _ -> return () mkPatRec :: - Located (PatBuilder GhcPs) -> - HsRecFields GhcPs (Located (PatBuilder GhcPs)) -> + LocatedA (PatBuilder GhcPs) -> + HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) -> + ApiAnn -> PV (PatBuilder GhcPs) -mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) +mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns | isRdrDataCon (unLoc c) = do fs <- mapM checkPatField fs return $ PatBuilderPat $ ConPat - { pat_con_ext = noExtField + { pat_con_ext = anns , pat_con = c , pat_args = RecCon (HsRecFields fs dd) } -mkPatRec p _ = - addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLoc p) +mkPatRec p _ _ = + addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p) -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor. @@ -1614,25 +1836,24 @@ mkPatRec p _ = class DisambTD b where -- | Process the head of a type-level function/constructor application, -- i.e. the @H@ in @H a b c@. - mkHsAppTyHeadPV :: LHsType GhcPs -> PV (Located b) + mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f x@ (function application or prefix data constructor). - mkHsAppTyPV :: Located b -> LHsType GhcPs -> PV (Located b) + mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \@t@ (visible kind application) - mkHsAppKindTyPV :: Located b -> SrcSpan -> LHsType GhcPs -> PV (Located b) + mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \# x@ (infix operator) - mkHsOpTyPV :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> PV (Located b) + mkHsOpTyPV :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) - mkUnpackednessPV :: Located UnpackednessPragma -> Located b -> PV (Located b) + mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) instance DisambTD (HsType GhcPs) where mkHsAppTyHeadPV = return mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) - mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l' t ki) - where l' = combineSrcSpans l_at (getLoc ki) + mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki) mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2) mkUnpackednessPV = addUnpackednessP -dataConBuilderCon :: DataConBuilder -> Located RdrName +dataConBuilderCon :: DataConBuilder -> LocatedN RdrName dataConBuilderCon (PrefixDataConBuilder _ dc) = dc dataConBuilderCon (InfixDataConBuilder _ dc _) = dc @@ -1641,8 +1862,8 @@ dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs -- Detect when the record syntax is used: -- data T = MkT { ... } dataConBuilderDetails (PrefixDataConBuilder flds _) - | [L l_t (HsRecTy _ fields)] <- toList flds - = RecCon (L l_t fields) + | [L l_t (HsRecTy an fields)] <- toList flds + = RecCon (L (SrcSpanAnn an (locA l_t)) fields) -- Normal prefix constructor, e.g. data T = MkT A B C dataConBuilderDetails (PrefixDataConBuilder flds _) @@ -1657,7 +1878,7 @@ instance DisambTD DataConBuilder where mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t = return $ - L (combineSrcSpans l (getLoc t)) + L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t)) (PrefixDataConBuilder (flds `snocOL` t) fn) mkHsAppTyPV (L _ InfixDataConBuilder{}) _ = -- This case is impossible because of the way @@ -1667,15 +1888,15 @@ instance DisambTD DataConBuilder where mkHsAppKindTyPV lhs l_at ki = addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at - mkHsOpTyPV lhs (L l_tc tc) rhs = do + mkHsOpTyPV lhs tc rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative - data_con <- eitherToP $ tyConToDataCon l_tc tc + data_con <- eitherToP $ tyConToDataCon tc return $ L l (InfixDataConBuilder lhs data_con rhs) where - l = combineLocs lhs rhs + l = combineLocsA lhs rhs check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) check_no_ops (HsOpTy{}) = - addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l + addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l) check_no_ops _ = return () mkUnpackednessPV unpk constr_stuff @@ -1683,21 +1904,21 @@ instance DisambTD DataConBuilder where = -- When the user writes data T = {-# UNPACK #-} Int :+ Bool -- we apply {-# UNPACK #-} to the LHS do lhs' <- addUnpackednessP unpk lhs - let l = combineLocs unpk constr_stuff + let l = combineLocsA (reLocA unpk) constr_stuff return $ L l (InfixDataConBuilder lhs' data_con rhs) | otherwise = do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk) return constr_stuff -tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder) -tyToDataConBuilder (L l (HsTyVar _ NotPromoted (L _ v))) = do - data_con <- eitherToP $ tyConToDataCon l v +tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) +tyToDataConBuilder (L l (HsTyVar _ NotPromoted v)) = do + data_con <- eitherToP $ tyConToDataCon v return $ L l (PrefixDataConBuilder nilOL data_con) tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do - let data_con = L l (getRdrName (tupleDataCon Boxed (length ts))) + let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t = - addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLoc t) + addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t) {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1768,13 +1989,13 @@ see Note [PatBuilder]). Consider the 'alts' production used to parse case-of alternatives: - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + alts :: { Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } We abstract over LHsExpr GhcPs, and it becomes: - alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) } + alts :: { forall b. DisambECP b => PV (Located ([AddApiAnn],[LMatch GhcPs (Located b)])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> @@ -1994,15 +2215,15 @@ However, there is a slight problem with this approach, namely code duplication in parser productions. Consider the 'alts' production used to parse case-of alternatives: - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + alts :: { Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } Under the new scheme, we have to completely duplicate its type signature and each reduction rule: - alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression - , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command + alts :: { ( PV (Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression + , PV (Located ([AddApiAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command ) } : alts1 { ( checkExpOf2 $1 >>= \ $1 -> @@ -2038,13 +2259,13 @@ as a function from a GADT: Consider the 'alts' production used to parse case-of alternatives: - alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + alts :: { Located ([AddApiAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } We abstract over LHsExpr, and it becomes: - alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + alts :: { forall b. ExpCmdG b -> PV (Located ([AddApiAnn],[LMatch GhcPs (Located (b GhcPs))])) } : alts1 { \tag -> $1 tag >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } @@ -2068,7 +2289,7 @@ the scenes: And now the 'alts' production is simplified, as we no longer need to thread 'tag' explicitly: - alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + alts :: { forall b. ExpCmdI b => PV (Located ([AddApiAnn],[LMatch GhcPs (Located (b GhcPs))])) } : alts1 { $1 >>= \ $1 -> return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } | ';' alts { $2 >>= \ $2 -> @@ -2125,8 +2346,8 @@ parsing results for patterns and function bindings: data PatBuilder p = PatBuilderPat (Pat p) - | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) - | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) + | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) + | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p)) ... It can represent any pattern via 'PatBuilderPat', but it also has a variety of @@ -2140,8 +2361,8 @@ pattern match on the pattern stored inside 'PatBuilderPat'. -- | Check if a fixity is valid. We support bypassing the usual bound checks -- for some special operators. checkPrecP - :: Located (SourceText,Int) -- ^ precedence - -> Located (OrdList (Located RdrName)) -- ^ operators + :: Located (SourceText,Int) -- ^ precedence + -> Located (OrdList (LocatedN RdrName)) -- ^ operators -> P () checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () @@ -2157,20 +2378,21 @@ mkRecConstrOrUpdate -> LHsExpr GhcPs -> SrcSpan -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) + -> ApiAnn -> PV (HsExpr GhcPs) -mkRecConstrOrUpdate _ (L l (HsVar _ (L _ c))) _lrec (fbinds,dd) +mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns | isRdrDataCon c = do let (fs, ps) = partitionEithers fbinds if not (null ps) - then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLoc (head ps)) - else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) -mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) + then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps)) + else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) +mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc - | otherwise = mkRdrRecordUpd overloaded_update exp fs + | otherwise = mkRdrRecordUpd overloaded_update exp fs anns -mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> PV (HsExpr GhcPs) -mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> ApiAnn -> PV (HsExpr GhcPs) +mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do -- We do not need to know if OverloadedRecordDot is in effect. We do -- however need to know if OverloadedRecordUpdate (passed in -- overloaded_on) is in effect because it affects the Left/Right nature @@ -2180,16 +2402,16 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do case overloaded_on of False | not $ null ps -> -- A '.' was found in an update and OverloadedRecordUpdate isn't on. - addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] loc + addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc) False -> -- This is just a regular record update. return RecordUpd { - rupd_ext = noExtField + rupd_ext = anns , rupd_expr = exp , rupd_flds = Left fs' } True -> do let qualifiedFields = - [ L l lbl | L _ (HsRecField (L l lbl) _ _) <- fs' + [ L l lbl | L _ (HsRecField _ (L l lbl) _ _) <- fs' , isQual . rdrNameAmbiguousFieldOcc $ lbl ] if not $ null qualifiedFields @@ -2197,7 +2419,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields)) else -- This is a RecordDotSyntax update. return RecordUpd { - rupd_ext = noExtField + rupd_ext = anns , rupd_expr = exp , rupd_flds = Right (toProjUpdates fbinds) } where @@ -2207,30 +2429,33 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds = do -- Convert a top-level field update like {foo=2} or {bar} (punned) -- to a projection update. recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs - recFieldToProjUpdate (L l (HsRecField (L _ (FieldOcc _ (L loc rdr))) arg pun)) = + recFieldToProjUpdate (L l (HsRecField anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = -- The idea here is to convert the label to a singleton [FastString]. let f = occNameFS . rdrNameOcc $ rdr - in mkRdrProjUpdate l (L loc [L loc f]) (punnedVar f) pun + fl = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann? + lf = locA loc + in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns where -- If punning, compute HsVar "f" otherwise just arg. This -- has the effect that sentinel HsVar "pun-rhs" is replaced -- by HsVar "f" here, before the update is written to a -- setField expressions. punnedVar :: FastString -> LHsExpr GhcPs - punnedVar f = if not pun then arg else noLoc . HsVar noExtField . noLoc . mkRdrUnqual . mkVarOccFS $ f + punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f -mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs -mkRdrRecordCon con flds - = RecordCon { rcon_ext = noExtField, rcon_con = con, rcon_flds = flds } +mkRdrRecordCon + :: LocatedN RdrName -> HsRecordBinds GhcPs -> ApiAnn -> HsExpr GhcPs +mkRdrRecordCon con flds anns + = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds } -mk_rec_fields :: [Located (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg +mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs , rec_dotdot = Just (L s (length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs -mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun) - = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun +mk_rec_upd_field (HsRecField noAnn (L loc (FieldOcc _ rdr)) arg pun) + = HsRecField noAnn (L loc (Unambiguous noExtField rdr)) arg pun mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma @@ -2257,9 +2482,9 @@ mkInlinePragma src (inl, match_info) mb_act -- mkImport :: Located CCallConv -> Located Safety - -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) - -> P (HsDecl GhcPs) -mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> P (ApiAnn -> HsDecl GhcPs) +mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case unLoc cconv of CCallConv -> mkCImport CApiConv -> mkCImport @@ -2287,8 +2512,8 @@ mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = funcTarget = CFunction (StaticTarget esrc entity' Nothing True) importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) - returnSpec spec = return $ ForD noExtField $ ForeignImport - { fd_i_ext = noExtField + returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport + { fd_i_ext = ann , fd_name = v , fd_sig_ty = ty , fd_fi = spec @@ -2358,11 +2583,11 @@ parseCImport cconv safety nm str sourceText = -- construct a foreign export declaration -- mkExport :: Located CCallConv - -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) - -> P (HsDecl GhcPs) -mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) - = return $ ForD noExtField $ - ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> P (ApiAnn -> HsDecl GhcPs) +mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) + = return $ \ann -> ForD noExtField $ + ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) (L le esrc) } where @@ -2383,23 +2608,25 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) data ImpExpSubSpec = ImpExpAbs | ImpExpAll - | ImpExpList [Located ImpExpQcSpec] - | ImpExpAllWith [Located ImpExpQcSpec] + | ImpExpList [LocatedA ImpExpQcSpec] + | ImpExpAllWith [LocatedA ImpExpQcSpec] -data ImpExpQcSpec = ImpExpQcName (Located RdrName) - | ImpExpQcType (Located RdrName) +data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName) + | ImpExpQcType AnnAnchor (LocatedN RdrName) | ImpExpQcWildcard -mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp (L l specname) subs = +mkModuleImpExp :: [AddApiAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) +mkModuleImpExp anns (L l specname) subs = do + cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments + let ann = ApiAnn (spanAsAnchor $ locA l) anns cs case subs of ImpExpAbs | isVarNameSpace (rdrNameSpace name) -> return $ IEVar noExtField (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs noExtField . L l <$> nameT - ImpExpAll -> IEThingAll noExtField . L l <$> nameT + | otherwise -> IEThingAbs ann . L l <$> nameT + ImpExpAll -> IEThingAll ann . L l <$> nameT ImpExpList xs -> - (\newName -> IEThingWith noExtField (L l newName) + (\newName -> IEThingWith ann (L l newName) NoIEWildcard (wrapped xs)) <$> nameT ImpExpAllWith xs -> do allowed <- getBit PatternSynonymsBit @@ -2408,49 +2635,50 @@ mkModuleImpExp (L l specname) subs = let withs = map unLoc xs pos = maybe NoIEWildcard IEWildcard (findIndex isImpExpQcWildcard withs) + ies :: [LocatedA (IEWrappedName RdrName)] ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName - -> IEThingWith noExtField (L l newName) pos ies) + -> IEThingWith ann (L l newName) pos ies) <$> nameT - else addFatalError $ PsError PsErrIllegalPatSynExport [] l + else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l) where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) - then addFatalError $ PsError (PsErrVarForTyCon name) [] l + then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l) else return $ ieNameFromSpec specname - ieNameVal (ImpExpQcName ln) = unLoc ln - ieNameVal (ImpExpQcType ln) = unLoc ln - ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" + ieNameVal (ImpExpQcName ln) = unLoc ln + ieNameVal (ImpExpQcType _ ln) = unLoc ln + ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - ieNameFromSpec (ImpExpQcName ln) = IEName ln - ieNameFromSpec (ImpExpQcType ln) = IEType ln - ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" + ieNameFromSpec (ImpExpQcName ln) = IEName ln + ieNameFromSpec (ImpExpQcType r ln) = IEType r ln + ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" wrapped = map (mapLoc ieNameFromSpec) -mkTypeImpExp :: Located RdrName -- TcCls or Var name space - -> P (Located RdrName) +mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space + -> P (LocatedN RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit - unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLoc name) + unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name) return (fmap (`setRdrNameSpace` tcClsName) name) -checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) +checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs]) checkImportSpec ie@(L _ specs) = case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of [] -> return ie - (l:_) -> importSpecError l + (l:_) -> importSpecError (locA l) where importSpecError l = addFatalError $ PsError PsErrIllegalImportBundleForm [] l -- In the correct order -mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) +mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddApiAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [L _ ImpExpQcWildcard] = - return ([], ImpExpAll) +mkImpExpSubSpec [L la ImpExpQcWildcard] = + return ([AddApiAnn AnnDotdot (AR $ la2r la)], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) then return $ ([], ImpExpAllWith xs) @@ -2476,10 +2704,10 @@ failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] warnStarIsType :: SrcSpan -> P () warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span) -failOpFewArgs :: MonadP m => Located RdrName -> m a +failOpFewArgs :: MonadP m => LocatedN RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit - ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] loc } + ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) } ----------------------------------------------------------------------------- -- Misc utils @@ -2492,11 +2720,10 @@ data PV_Context = data PV_Accum = PV_Accum - { pv_warnings :: Bag PsWarning - , pv_errors :: Bag PsError - , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])] - , pv_comment_q :: [RealLocated AnnotationComment] - , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])] + { pv_warnings :: Bag PsWarning + , pv_errors :: Bag PsError + , pv_header_comments :: Maybe [LAnnotationComment] + , pv_comment_q :: [LAnnotationComment] } data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum @@ -2548,15 +2775,12 @@ runPV_hints hints m = pv_acc = PV_Accum { pv_warnings = warnings s , pv_errors = errors s - , pv_annotations = annotations s - , pv_comment_q = comment_q s - , pv_annotations_comments = annotations_comments s } + , pv_header_comments = header_comments s + , pv_comment_q = comment_q s } mkPState acc' = s { warnings = pv_warnings acc' , errors = pv_errors acc' - , annotations = pv_annotations acc' - , comment_q = pv_comment_q acc' - , annotations_comments = pv_annotations_comments acc' } + , comment_q = pv_comment_q acc' } in case unPV m pv_ctx pv_acc of PV_Ok acc' a -> POk (mkPState acc') a @@ -2584,19 +2808,25 @@ instance MonadP PV where PV $ \ctx acc -> let b = ext `xtest` pExtsBitmap (pv_options ctx) in PV_Ok acc $! b - addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = - PV $ \_ acc -> - let - (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc) - annotations_comments' = new_ann_comments ++ pv_annotations_comments acc - annotations' = ((l,a), [v]) : pv_annotations acc - acc' = acc - { pv_annotations = annotations' - , pv_comment_q = comment_q' - , pv_annotations_comments = annotations_comments' } - in - PV_Ok acc' () - addAnnotation _ _ _ = return () + allocateCommentsP ss = PV $ \_ s -> + let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in + PV_Ok s { + pv_comment_q = comment_q' + } (AnnComments newAnns) + allocatePriorCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (AnnComments newAnns) + allocateFinalCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (AnnCommentsBalanced [] (reverse newAnns)) {- Note [Parser-Validator Hint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2647,52 +2877,68 @@ hintBangPat span e = do unless bang_on $ addError $ PsError (PsErrIllegalBangPattern e) [] span -mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) +mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) + -> [AddApiAnn] + -> PV (LHsExpr GhcPs) -- Tuple -mkSumOrTupleExpr l boxity (Tuple es) = - return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity) +mkSumOrTupleExpr l boxity (Tuple es) anns = do + cs <- getCommentsFor (locA l) + return $ L l (ExplicitTuple (ApiAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity) where - toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs - toTupArg = mapLoc (maybe missingTupArg (Present noExtField)) + toTupArg :: Either (ApiAnn' AnnAnchor) (LHsExpr GhcPs) -> HsTupArg GhcPs + toTupArg (Left ann) = missingTupArg ann + toTupArg (Right a) = Present noAnn a -- Sum -mkSumOrTupleExpr l Unboxed (Sum alt arity e) = - return $ L l (ExplicitSum noExtField alt arity e) -mkSumOrTupleExpr l Boxed a@Sum{} = - addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] l - -mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) +-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) = +-- return $ L l (ExplicitSum noExtField alt arity e) +mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do + let an = case anns of + [AddApiAnn AnnOpenPH o, AddApiAnn AnnClosePH c] -> + AnnExplicitSum o barsp barsa c + _ -> panic "mkSumOrTupleExpr" + cs <- getCommentsFor (locA l) + return $ L l (ExplicitSum (ApiAnn (spanAsAnchor $ locA l) an cs) alt arity e) +mkSumOrTupleExpr l Boxed a@Sum{} _ = + addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l) + +mkSumOrTuplePat + :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddApiAnn] + -> PV (LocatedA (PatBuilder GhcPs)) -- Tuple -mkSumOrTuplePat l boxity (Tuple ps) = do +mkSumOrTuplePat l boxity (Tuple ps) anns = do ps' <- traverse toTupPat ps - return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity)) + cs <- getCommentsFor (locA l) + return $ L l (PatBuilderPat (TuplePat (ApiAnn (spanAsAnchor $ locA l) anns cs) ps' boxity)) where - toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) + toTupPat :: Either (ApiAnn' AnnAnchor) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) -- Ignore the element location so that the error message refers to the -- entire tuple. See #19504 (and the discussion) for details. - toTupPat (L _ p) = case p of - Nothing -> addFatalError $ PsError PsErrTupleSectionInPat [] l - Just p' -> checkLPat p' + toTupPat p = case p of + Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l) + Right p' -> checkLPat p' -- Sum -mkSumOrTuplePat l Unboxed (Sum alt arity p) = do +mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do p' <- checkLPat p - return $ L l (PatBuilderPat (SumPat noExtField p' alt arity)) -mkSumOrTuplePat l Boxed a@Sum{} = - addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] l + cs <- getCommentsFor (locA l) + let an = ApiAnn (spanAsAnchor $ locA l) (ApiAnnSumPat anns barsb barsa) cs + return $ L l (PatBuilderPat (SumPat an p' alt arity)) +mkSumOrTuplePat l Boxed a@Sum{} _ = + addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l) -mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = - let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y + let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y in L loc (mkHsOpTy x op y) -mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn) +mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> HsArrow GhcPs mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) -- See #18888 for the use of (SourceText "1") above - = (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t)) -mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok)) + = HsLinearArrow u (Just $ AddApiAnn AnnPercentOne (AR $ realSrcSpan $ combineLocs tok (reLoc t))) +mkMultTy u tok t = HsExplicitMult u (Just $ AddApiAnn AnnPercent (AR $ realSrcSpan $ getLoc tok)) t ----------------------------------------------------------------------------- -- Token symbols @@ -2704,27 +2950,31 @@ starSym False = "*" ----------------------------------------- -- Bits and pieces for RecordDotSyntax. -mkRdrGetField :: SrcSpan -> LHsExpr GhcPs -> Located FieldLabelString -> LHsExpr GhcPs -mkRdrGetField loc arg field = +mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs) + -> ApiAnnCO -> LHsExpr GhcPs +mkRdrGetField loc arg field anns = L loc HsGetField { - gf_ext = noExtField + gf_ext = anns , gf_expr = arg , gf_field = field } -mkRdrProjection :: SrcSpan -> [Located FieldLabelString] -> LHsExpr GhcPs -mkRdrProjection _ [] = panic "mkRdrProjection: The impossible has happened!" -mkRdrProjection loc flds = - L loc HsProjection { - proj_ext = noExtField +mkRdrProjection :: [Located (HsFieldLabel GhcPs)] -> ApiAnn' AnnProjection -> HsExpr GhcPs +mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!" +mkRdrProjection flds anns = + HsProjection { + proj_ext = anns , proj_flds = flds } -mkRdrProjUpdate :: SrcSpan -> Located [Located FieldLabelString] -> LHsExpr GhcPs -> Bool -> LHsRecProj GhcPs (LHsExpr GhcPs) -mkRdrProjUpdate _ (L _ []) _ _ = panic "mkRdrProjUpdate: The impossible has happened!" -mkRdrProjUpdate loc (L l flds) arg isPun = +mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)] + -> LHsExpr GhcPs -> Bool -> ApiAnn + -> LHsRecProj GhcPs (LHsExpr GhcPs) +mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" +mkRdrProjUpdate loc (L l flds) arg isPun anns = L loc HsRecField { - hsRecFieldLbl = L l (FieldLabelStrings flds) + hsRecFieldAnn = anns + , hsRecFieldLbl = L l (FieldLabelStrings flds) , hsRecFieldArg = arg , hsRecPun = isPun } diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index c226b777ba..393e2ed349 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -300,15 +300,15 @@ instance HasHaddock (Located HsModule) where -- import I (a, b, c) -- do not use here! -- -- Imports cannot have documentation comments anyway. -instance HasHaddock (Located [Located (IE GhcPs)]) where +instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where addHaddock (L l_exports exports) = - extendHdkA l_exports $ do + extendHdkA (locA l_exports) $ do exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports - registerLocHdkA (srcLocSpan (srcSpanEnd l_exports)) -- Do not consume comments after the closing parenthesis + registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis pure $ L l_exports exports' -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. -instance HasHaddock (Located (IE GhcPs)) where +instance HasHaddock (LocatedA (IE GhcPs)) where addHaddock a = a <$ registerHdkA a {- Add Haddock items to a list of non-Haddock items. @@ -385,10 +385,10 @@ addHaddockInterleaveItems layout_info get_doc_item = go let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } in hoistHdkA (inLocRange loc_range) -instance HasHaddock (Located (HsDecl GhcPs)) where +instance HasHaddock (LocatedA (HsDecl GhcPs)) where addHaddock ldecl = - extendHdkA (getLoc ldecl) $ - traverse @Located addHaddock ldecl + extendHdkA (getLocA ldecl) $ + traverse @LocatedA addHaddock ldecl -- Process documentation comments *inside* a declaration, for example: -- @@ -421,10 +421,10 @@ instance HasHaddock (HsDecl GhcPs) where -- :: Int -- ^ Comment on Int -- -> Bool -- ^ Comment on Bool -- - addHaddock (SigD _ (TypeSig _ names t)) = do + addHaddock (SigD _ (TypeSig x names t)) = do traverse_ registerHdkA names t' <- addHaddock t - pure (SigD noExtField (TypeSig noExtField names t')) + pure (SigD noExtField (TypeSig x names t')) -- Pattern synonym type signatures: -- @@ -432,10 +432,10 @@ instance HasHaddock (HsDecl GhcPs) where -- :: Bool -- ^ Comment on Bool -- -> Maybe Bool -- ^ Comment on Maybe Bool -- - addHaddock (SigD _ (PatSynSig _ names t)) = do + addHaddock (SigD _ (PatSynSig x names t)) = do traverse_ registerHdkA names t' <- addHaddock t - pure (SigD noExtField (PatSynSig noExtField names t')) + pure (SigD noExtField (PatSynSig x names t')) -- Class method signatures and default signatures: -- @@ -448,10 +448,10 @@ instance HasHaddock (HsDecl GhcPs) where -- => Maybe x -- ^ Comment on Maybe x -- -> IO () -- ^ Comment on IO () -- - addHaddock (SigD _ (ClassOpSig _ is_dflt names t)) = do + addHaddock (SigD _ (ClassOpSig x is_dflt names t)) = do traverse_ registerHdkA names t' <- addHaddock t - pure (SigD noExtField (ClassOpSig noExtField is_dflt names t')) + pure (SigD noExtField (ClassOpSig x is_dflt names t')) -- Data/newtype declarations: -- @@ -469,14 +469,14 @@ instance HasHaddock (HsDecl GhcPs) where -- deriving newtype (Eq {- ^ Comment on Eq N -}) -- deriving newtype (Ord {- ^ Comment on Ord N -}) -- - addHaddock (TyClD _ decl) - | DataDecl { tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl + addHaddock (TyClD x decl) + | DataDecl { tcdDExt, tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl = do registerHdkA tcdLName defn' <- addHaddock defn pure $ - TyClD noExtField (DataDecl { - tcdDExt = noExtField, + TyClD x (DataDecl { + tcdDExt, tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn' }) @@ -489,7 +489,7 @@ instance HasHaddock (HsDecl GhcPs) where -- -- ^ Comment on the second method -- addHaddock (TyClD _ decl) - | ClassDecl { tcdCExt = tcdLayout, + | ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout), tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl = do @@ -500,7 +500,7 @@ instance HasHaddock (HsDecl GhcPs) where flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], []) pure $ let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls' - decl' = ClassDecl { tcdCExt = tcdLayout + decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout) , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs , tcdSigs = tcdSigs' , tcdMeths = tcdMeths' @@ -515,20 +515,20 @@ instance HasHaddock (HsDecl GhcPs) where -- data instance D Bool = ... (same as data/newtype declarations) -- addHaddock (InstD _ decl) - | DataFamInstD { dfid_inst } <- decl + | DataFamInstD { dfid_ext, dfid_inst } <- decl , DataFamInstDecl { dfid_eqn } <- dfid_inst = do dfid_eqn' <- case dfid_eqn of - FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs } + FamEqn { feqn_ext, feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs } -> do registerHdkA feqn_tycon feqn_rhs' <- addHaddock feqn_rhs pure $ FamEqn { - feqn_ext = noExtField, + feqn_ext, feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs = feqn_rhs' } pure $ InstD noExtField (DataFamInstD { - dfid_ext = noExtField, + dfid_ext, dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } }) -- Type synonyms: @@ -536,14 +536,14 @@ instance HasHaddock (HsDecl GhcPs) where -- type T = Int -- ^ Comment on Int -- addHaddock (TyClD _ decl) - | SynDecl { tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl + | SynDecl { tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl = do registerHdkA tcdLName -- todo: register keyword location of '=', see Note [Register keyword location] tcdRhs' <- addHaddock tcdRhs pure $ TyClD noExtField (SynDecl { - tcdSExt = noExtField, + tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs = tcdRhs' }) @@ -609,7 +609,7 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where extendHdkA (getLoc lderiv) $ for @Located lderiv $ \deriv -> case deriv of - HsDerivingClause { deriv_clause_strategy, deriv_clause_tys } -> do + HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do let -- 'stock', 'anyclass', and 'newtype' strategies come -- before the clause types. @@ -626,7 +626,7 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where deriv_clause_tys' <- addHaddock deriv_clause_tys register_strategy_after pure HsDerivingClause - { deriv_clause_ext = noExtField, + { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys = deriv_clause_tys' } @@ -640,9 +640,9 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where -- deriving ( Eq -- ^ Comment on Eq -- , C a -- ^ Comment on C a -- ) -instance HasHaddock (Located (DerivClauseTys GhcPs)) where +instance HasHaddock (LocatedC (DerivClauseTys GhcPs)) where addHaddock (L l_dct dct) = - extendHdkA l_dct $ + extendHdkA (locA l_dct) $ case dct of DctSingle x ty -> do ty' <- addHaddock ty @@ -685,13 +685,13 @@ instance HasHaddock (Located (DerivClauseTys GhcPs)) where -- bool_field :: Bool } -- ^ Comment on bool_field -- -> T -- -instance HasHaddock (Located (ConDecl GhcPs)) where +instance HasHaddock (LocatedA (ConDecl GhcPs)) where addHaddock (L l_con_decl con_decl) = - extendHdkA l_con_decl $ + extendHdkA (locA l_con_decl) $ case con_decl of ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. - con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names)) + con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (head con_names)) con_g_args' <- case con_g_args of PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts @@ -706,10 +706,10 @@ instance HasHaddock (Located (ConDecl GhcPs)) where con_g_args = con_g_args', con_res_ty = con_res_ty' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> - addConTrailingDoc (srcSpanEnd l_con_decl) $ + addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $ case con_args of PrefixCon _ ts -> do - con_doc' <- getConDoc (getLoc con_name) + con_doc' <- getConDoc (getLocA con_name) ts' <- traverse addHaddockConDeclFieldTy ts pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, @@ -717,14 +717,14 @@ instance HasHaddock (Located (ConDecl GhcPs)) where con_args = PrefixCon noTypeArgs ts' } InfixCon t1 t2 -> do t1' <- addHaddockConDeclFieldTy t1 - con_doc' <- getConDoc (getLoc con_name) + con_doc' <- getConDoc (getLocA con_name) t2' <- addHaddockConDeclFieldTy t2 pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_doc = con_doc', con_args = InfixCon t1' t2' } RecCon (L l_rec flds) -> do - con_doc' <- getConDoc (getLoc con_name) + con_doc' <- getConDoc (getLocA con_name) flds' <- traverse addHaddockConDeclField flds pure $ L l_con_decl $ ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, @@ -782,8 +782,8 @@ addHaddockConDeclFieldTy :: HsScaled GhcPs (LHsType GhcPs) -> ConHdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy (HsScaled mult (L l t)) = - WriterT $ extendHdkA l $ liftHdkA $ do - mDoc <- getPrevNextDoc l + WriterT $ extendHdkA (locA l) $ liftHdkA $ do + mDoc <- getPrevNextDoc (locA l) return (HsScaled mult (mkLHsDocTy (L l t) mDoc), HasInnerDocs (isJust mDoc)) @@ -793,8 +793,8 @@ addHaddockConDeclField :: LConDeclField GhcPs -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField (L l_fld fld) = - WriterT $ extendHdkA l_fld $ liftHdkA $ do - cd_fld_doc <- getPrevNextDoc l_fld + WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do + cd_fld_doc <- getPrevNextDoc (locA l_fld) return (L l_fld (fld { cd_fld_doc }), HasInnerDocs (isJust cd_fld_doc)) @@ -930,9 +930,9 @@ instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t -instance HasHaddock (Located (HsSigType GhcPs)) where +instance HasHaddock (LocatedA (HsSigType GhcPs)) where addHaddock (L l (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = - extendHdkA l $ do + extendHdkA (locA l) $ do case outer_bndrs of HsOuterImplicit{} -> pure () HsOuterExplicit{hso_bndrs = bndrs} -> @@ -967,22 +967,22 @@ instance HasHaddock (Located (HsSigType GhcPs)) where -- -- This is achieved by simply ignoring (not registering the location of) the -- function arrow (->). -instance HasHaddock (Located (HsType GhcPs)) where +instance HasHaddock (LocatedA (HsType GhcPs)) where addHaddock (L l t) = - extendHdkA l $ + extendHdkA (locA l) $ case t of -- forall a b c. t - HsForAllTy _ tele body -> do + HsForAllTy x tele body -> do registerLocHdkA (getForAllTeleLoc tele) body' <- addHaddock body - pure $ L l (HsForAllTy noExtField tele body') + pure $ L l (HsForAllTy x tele body') -- (Eq a, Num a) => t - HsQualTy _ mlhs rhs -> do - traverse registerHdkA mlhs + HsQualTy x mlhs rhs -> do + traverse_ registerHdkA mlhs rhs' <- addHaddock rhs - pure $ L l (HsQualTy noExtField mlhs rhs') + pure $ L l (HsQualTy x mlhs rhs') -- arg -> res HsFunTy u mult lhs rhs -> do @@ -992,7 +992,7 @@ instance HasHaddock (Located (HsType GhcPs)) where -- other types _ -> liftHdkA $ do - mDoc <- getPrevNextDoc l + mDoc <- getPrevNextDoc (locA l) return (mkLHsDocTy (L l t) mDoc) {- ********************************************************************* @@ -1145,8 +1145,8 @@ registerLocHdkA l = HdkA (getBufSpan l) (pure ()) -- A small wrapper over registerLocHdkA. -- -- See Note [Adding Haddock comments to the syntax tree]. -registerHdkA :: Located a -> HdkA () -registerHdkA a = registerLocHdkA (getLoc a) +registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA () +registerHdkA a = registerLocHdkA (getLocA a) -- Modify the action of a HdkA computation. hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b @@ -1302,11 +1302,11 @@ reportExtraDocs = mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a -mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl +mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = - Just $ L (mkSrcSpanPs l_comment) $ + Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $ case hdk_comment of HdkCommentNext doc -> DocCommentNext doc HdkCommentPrev doc -> DocCommentPrev doc @@ -1345,7 +1345,7 @@ mkDocIE (L l_comment hdk_comment) = HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc) _ -> Nothing - where l = mkSrcSpanPs l_comment + where l = noAnnSrcSpan $ mkSrcSpanPs l_comment mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc @@ -1467,7 +1467,7 @@ instance Monoid ColumnBound where mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTy t Nothing = t -mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t doc) +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc) getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele = @@ -1476,7 +1476,7 @@ getForAllTeleLoc tele = HsForAllInvis { hsf_invis_bndrs } -> getLHsTyVarBndrsLoc hsf_invis_bndrs getLHsTyVarBndrsLoc :: [LHsTyVarBndr flag GhcPs] -> SrcSpan -getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLoc bndrs +getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLocA bndrs -- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back -- into a flat list. Elements are put back into the order in which they @@ -1486,22 +1486,25 @@ getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLoc bndrs -- Precondition (unchecked): the input lists are already sorted. flattenBindsAndSigs :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], - [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) -> [LHsDecl GhcPs] flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) = -- 'cmpBufSpan' is safe here with the following assumptions: -- -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan' -- - 'partitionBindsAndSigs' does not discard this 'BufSpan' - mergeListsBy cmpBufSpan [ + mergeListsBy cmpBufSpanA [ mapLL (\b -> ValD noExtField b) (bagToList all_bs), mapLL (\s -> SigD noExtField s) all_ss, mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts, mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis, - mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis, + mapLL (\dfi -> InstD noExtField (DataFamInstD noAnn dfi)) all_dfis, mapLL (\d -> DocD noExtField d) all_docs ] +cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering +cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b) + {- ********************************************************************* * * * General purpose utilities * @@ -1513,7 +1516,7 @@ mcons :: Maybe a -> [a] -> [a] mcons = maybe id (:) -- Map a function over a list of located items. -mapLL :: (a -> b) -> [Located a] -> [Located b] +mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b] mapLL f = map (mapLoc f) {- Note [Old solution: Haddock in the grammar] diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs index ba7ca1d9c1..843685ea36 100644 --- a/compiler/GHC/Parser/Types.hs +++ b/compiler/GHC/Parser/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} @@ -21,20 +22,26 @@ import GHC.Utils.Outputable as Outputable import GHC.Data.OrdList import Data.Foldable +import GHC.Parser.Annotation +import Language.Haskell.Syntax data SumOrTuple b - = Sum ConTag Arity (Located b) - | Tuple [Located (Maybe (Located b))] + = Sum ConTag Arity (LocatedA b) [AnnAnchor] [AnnAnchor] + -- ^ Last two are the locations of the '|' before and after the payload + | Tuple [Either (ApiAnn' AnnAnchor) (LocatedA b)] pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc pprSumOrTuple boxity = \case - Sum alt arity e -> + Sum alt arity e _ _ -> parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) <+> parClose Tuple xs -> - parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs) + parOpen <> (fcat . punctuate comma $ map ppr_tup xs) <> parClose where + ppr_tup (Left _) = empty + ppr_tup (Right e) = ppr e + ppr_bars n = hsep (replicate n (Outputable.char '|')) (parOpen, parClose) = case boxity of @@ -45,19 +52,20 @@ pprSumOrTuple boxity = \case -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p = PatBuilderPat (Pat p) - | PatBuilderPar (Located (PatBuilder p)) - | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p)) - | PatBuilderAppType (Located (PatBuilder p)) (HsPatSigType GhcPs) - | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p)) - | PatBuilderVar (Located RdrName) + | PatBuilderPar (LocatedA (PatBuilder p)) AnnParen + | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) + | PatBuilderAppType (LocatedA (PatBuilder p)) SrcSpan (HsPatSigType GhcPs) + | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) + (LocatedA (PatBuilder p)) ApiAnn + | PatBuilderVar (LocatedN RdrName) | PatBuilderOverLit (HsOverLit GhcPs) instance Outputable (PatBuilder GhcPs) where ppr (PatBuilderPat p) = ppr p - ppr (PatBuilderPar (L _ p)) = parens (ppr p) + ppr (PatBuilderPar (L _ p) _) = parens (ppr p) ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 - ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t - ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2 + ppr (PatBuilderAppType (L _ p) _ t) = ppr p <+> text "@" <> ppr t + ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2 ppr (PatBuilderVar v) = ppr v ppr (PatBuilderOverLit l) = ppr l @@ -83,11 +91,11 @@ instance Outputable (PatBuilder GhcPs) where data DataConBuilder = PrefixDataConBuilder (OrdList (LHsType GhcPs)) -- Data constructor fields - (Located RdrName) -- Data constructor name + (LocatedN RdrName) -- Data constructor name | InfixDataConBuilder - (LHsType GhcPs) -- LHS field - (Located RdrName) -- Data constructor name - (LHsType GhcPs) -- RHS field + (LHsType GhcPs) -- LHS field + (LocatedN RdrName) -- Data constructor name + (LHsType GhcPs) -- RHS field instance Outputable DataConBuilder where ppr (PrefixDataConBuilder flds data_con) = @@ -95,3 +103,4 @@ instance Outputable DataConBuilder where ppr (InfixDataConBuilder lhs data_con rhs) = ppr lhs <+> ppr data_con <+> ppr rhs +type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index fdcf89104f..d98c9a05c3 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} @@ -31,7 +32,7 @@ module GHC.Rename.Bind ( import GHC.Prelude -import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts ) +import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts ) import GHC.Hs import GHC.Tc.Utils.Monad @@ -41,7 +42,7 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn - , checkDupRdrNames, warnUnusedLocalBinds + , checkDupRdrNames, checkDupRdrNamesN, warnUnusedLocalBinds , checkUnusedRecordWildcard , checkDupAndShadowedNames, bindLocalNamesFV , addNoNestedForallsContextsErr, checkInferredVars ) @@ -224,13 +225,13 @@ rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) rnIPBinds (IPBinds _ ip_binds ) = do - (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds + (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstMA rnIPBind) ip_binds return (IPBinds noExtField ip_binds', plusFVs fvs_s) rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) rnIPBind (IPBind _ ~(Left n) expr) = do (expr',fvExpr) <- rnLExpr expr - return (IPBind noExtField (Left n) expr', fvExpr) + return (IPBind noAnn (Left n) expr', fvExpr) {- ************************************************************************ @@ -282,7 +283,7 @@ rnValBindsLHS :: NameMaker -> HsValBinds GhcPs -> RnM (HsValBindsLR GhcRn GhcPs) rnValBindsLHS topP (ValBinds x mbinds sigs) - = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds + = do { mbinds' <- mapBagM (wrapLocMA (rnBindLHS topP doc)) mbinds ; return $ ValBinds x mbinds' sigs } where bndrs = collectHsBindsBinders CollNoDictBinders mbinds @@ -429,15 +430,15 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) | isTopRecNameMaker name_maker - = do { addLocM checkConName rdrname - ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already - ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + = do { addLocMA checkConName rdrname + ; name <- lookupLocatedTopBndrRnN rdrname -- Should be in scope already + ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } | otherwise -- Pattern synonym, not at top level = do { addErr localPatternSynonymErr -- Complain, but make up a fake -- name so that we can carry on ; name <- applyNameMaker name_maker rdrname - ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr @@ -450,7 +451,7 @@ rnLBind :: (Name -> [Name]) -- Signature tyvar function -> LHsBindLR GhcRn GhcPs -> RnM (LHsBind GhcRn, [Name], Uses) rnLBind sig_fn (L loc bind) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { (bind', bndrs, dus) <- rnBind sig_fn bind ; return (L loc bind', bndrs, dus) } @@ -608,7 +609,7 @@ mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where env = mkHsSigEnv get_scoped_tvs sigs - get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) + get_scoped_tvs :: LSig GhcRn -> Maybe ([LocatedN Name], [Name]) -- Returns (binders, scoped tvs for those binders) get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) = Just (names, hsScopedTvs sig_ty) @@ -631,7 +632,7 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls where add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv add_one_sig env (L loc (FixitySig _ names fixity)) = - foldlM add_one env [ (loc,name_loc,name,fixity) + foldlM add_one env [ (locA loc,locA name_loc,name,fixity) | L name_loc name <- names ] add_one env (loc, name_loc, name,fixity) = do @@ -681,7 +682,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name -- from the left-hand side case details of PrefixCon _ vars -> - do { checkDupRdrNames vars + do { checkDupRdrNamesN vars ; names <- mapM lookupPatSynBndr vars ; return ( (pat', PrefixCon noTypeArgs names) , mkFVs (map unLoc names)) } @@ -738,7 +739,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name } where -- See Note [Renaming pattern synonym variables] - lookupPatSynBndr = wrapLocM lookupLocalOccRn + lookupPatSynBndr = wrapLocMA lookupLocalOccRn patternSynonymErr :: SDoc patternSynonymErr @@ -843,7 +844,7 @@ rnMethodBinds :: Bool -- True <=> is a class declaration -- * the default method bindings in a class decl -- * the method bindings in an instance decl rnMethodBinds is_cls_decl cls ktv_names binds sigs - = do { checkDupRdrNames (collectMethodBinders binds) + = do { checkDupRdrNamesN (collectMethodBinders binds) -- Check that the same method is not given twice in the -- same instance decl instance C T where -- f x = ... @@ -888,8 +889,8 @@ rnMethodBindLHS :: Bool -> Name -> LHsBindsLR GhcRn GhcPs -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest - = setSrcSpan loc $ - do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name + = setSrcSpanA loc $ do + do { sel_name <- wrapLocMA (lookupInstDeclBndr cls (text "method")) name -- We use the selector name as the binder ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } ; return (L loc bind' `consBag` rest ) } @@ -897,7 +898,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt loc $ + = do { addErrAt (locA loc) $ vcat [ what <+> text "not allowed in" <+> decl_sort , nest 2 (ppr bind) ] ; return rest } @@ -936,7 +937,7 @@ renameSigs ctxt sigs ; checkDupMinimalSigs sigs - ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstMA (renameSig ctxt)) sigs ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' ; mapM_ misplacedSigErr bad_sigs -- Misplaced @@ -958,18 +959,18 @@ renameSig _ (IdSig _ x) = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs renameSig ctxt sig@(TypeSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) ; (new_ty, fvs) <- rnHsSigWcType doc ty - ; return (TypeSig noExtField new_vs new_ty, fvs) } + ; return (TypeSig noAnn new_vs new_ty, fvs) } renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures ; when (is_deflt && not defaultSigs_on) $ addErr (defaultSigErr sig) - ; new_v <- mapM (lookupSigOccRn ctxt sig) vs + ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty - ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } + ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) } where (v1:_) = vs ty_ctxt = GenericCtx (text "a class method signature for" @@ -984,7 +985,7 @@ renameSig _ (SpecInstSig _ src ty) -- GHC.Hs.Type). ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type") (getLHsInstDeclHead new_ty) - ; return (SpecInstSig noExtField src new_ty,fvs) } + ; return (SpecInstSig noAnn src new_ty,fvs) } where doc = SpecInstSigCtx inf_msg = Just (text "Inferred type variables are not allowed") @@ -996,9 +997,9 @@ renameSig _ (SpecInstSig _ src ty) renameSig ctxt sig@(SpecSig _ v tys inl) = do { new_v <- case ctxt of TopSigCtxt {} -> lookupLocatedOccRn v - _ -> lookupSigOccRn ctxt sig v + _ -> lookupSigOccRnN ctxt sig v ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys - ; return (SpecSig noExtField new_v new_ty inl, fvs) } + ; return (SpecSig noAnn new_v new_ty inl, fvs) } where ty_ctxt = GenericCtx (text "a SPECIALISE signature for" <+> quotes (ppr v)) @@ -1007,28 +1008,28 @@ renameSig ctxt sig@(SpecSig _ v tys inl) ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig ctxt sig@(InlineSig _ v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig noExtField new_v s, emptyFVs) } + = do { new_v <- lookupSigOccRnN ctxt sig v + ; return (InlineSig noAnn new_v s, emptyFVs) } renameSig ctxt (FixSig _ fsig) = do { new_fsig <- rnSrcFixityDecl ctxt fsig - ; return (FixSig noExtField new_fsig, emptyFVs) } + ; return (FixSig noAnn new_fsig, emptyFVs) } renameSig ctxt sig@(MinimalSig _ s (L l bf)) - = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf - return (MinimalSig noExtField s (L l new_bf), emptyFVs) + = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf + return (MinimalSig noAnn s (L l new_bf), emptyFVs) renameSig ctxt sig@(PatSynSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty - ; return (PatSynSig noExtField new_vs ty', fvs) } + ; return (PatSynSig noAnn new_vs ty', fvs) } where ty_ctxt = GenericCtx (text "a pattern synonym signature for" <+> ppr_sig_bndrs vs) renameSig ctxt sig@(SCCFunSig _ st v s) - = do { new_v <- lookupSigOccRn ctxt sig v - ; return (SCCFunSig noExtField st new_v s, emptyFVs) } + = do { new_v <- lookupSigOccRnN ctxt sig v + ; return (SCCFunSig noAnn st new_v s, emptyFVs) } -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn @@ -1041,7 +1042,7 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs) + return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs) where orphanError :: SDoc orphanError = @@ -1071,7 +1072,7 @@ For now we simply disallow orphan COMPLETE pragmas, as the added complexity of supporting them properly doesn't seem worthwhile. -} -ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool @@ -1116,7 +1117,7 @@ okHsSig ctxt (L _ sig) (CompleteMatchSig {}, _) -> False ------------------- -findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] +findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)] -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors @@ -1128,6 +1129,7 @@ findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] findDupSigs sigs = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) where + expand_sig :: Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)] -- AZ expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) expand_sig sig@(InlineSig _ n _) = [(n,sig)] expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] @@ -1136,6 +1138,7 @@ findDupSigs sigs expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] expand_sig _ = [] + matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 mtch (FixSig {}) (FixSig {}) = True mtch (InlineSig {}) (InlineSig {}) = True @@ -1160,35 +1163,46 @@ checkDupMinimalSigs sigs ************************************************************************ -} -rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> MatchGroup GhcPs (Located (body GhcPs)) - -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) -rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) +type AnnoBody body + = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL + , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL + , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan + , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan + , Outputable (body GhcPs) + ) + +rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> MatchGroup GhcPs (LocatedA (body GhcPs)) + -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) +rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin }) = do { empty_case_ok <- xoptM LangExt.EmptyCase ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms - ; return (mkMatchGroup origin new_ms, ms_fvs) } - -rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> LMatch GhcPs (Located (body GhcPs)) - -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) -rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) - --- Note that there are no local fixity decls for matches -rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> Match GhcPs (Located (body GhcPs)) - -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) -rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) = - rnPats ctxt pats $ \ pats' -> do + ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) } + +rnMatch :: AnnoBody body + => HsMatchContext GhcRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> LMatch GhcPs (LocatedA (body GhcPs)) + -> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody) + +rnMatch' :: (AnnoBody body) + => HsMatchContext GhcRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> Match GhcPs (LocatedA (body GhcPs)) + -> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars) +rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) + = rnPats ctxt pats $ \ pats' -> do { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss ; let mf' = case (ctxt, mf) of - (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) -> - mf { mc_fun = L lf funid } - _ -> ctxt - ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' + (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) + -> mf { mc_fun = L lf funid } + _ -> ctxt + ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats' , m_grhss = grhss'}, grhss_fvs ) } emptyCaseErr :: HsMatchContext GhcRn -> SDoc @@ -1208,34 +1222,36 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) ************************************************************************ -} -rnGRHSs :: HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> GRHSs GhcPs (Located (body GhcPs)) - -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) -rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) +rnGRHSs :: AnnoBody body + => HsMatchContext GhcRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> GRHSs GhcPs (LocatedA (body GhcPs)) + -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs _ grhss binds) = rnLocalBindsAndThen binds $ \ binds' _ -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss - return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) + return (GRHSs noExtField grhss' binds', fvGRHSs) -rnGRHS :: HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> LGRHS GhcPs (Located (body GhcPs)) - -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) +rnGRHS :: AnnoBody body + => HsMatchContext GhcRn + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> LGRHS GhcPs (LocatedA (body GhcPs)) + -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars) rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) rnGRHS' :: HsMatchContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> GRHS GhcPs (Located (body GhcPs)) - -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) + -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) + -> GRHS GhcPs (LocatedA (body GhcPs)) + -> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars) rnGRHS' ctxt rnBody (GRHS _ guards rhs) = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ -> rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') (addWarn NoReason (nonStdGuardErr guards')) - ; return (GRHS noExtField guards' rhs', fvs) } + ; return (GRHS noAnn guards' rhs', fvs) } where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the @@ -1267,9 +1283,9 @@ rnSrcFixityDecl sig_ctxt = rn_decl = do names <- concatMapM lookup_one fnames return (FixitySig noExtField names fixity) - lookup_one :: Located RdrName -> RnM [Located Name] + lookup_one :: LocatedN RdrName -> RnM [LocatedN Name] lookup_one (L name_loc rdr_name) - = setSrcSpan name_loc $ + = setSrcSpanA name_loc $ -- This lookup will fail if the name is not defined in the -- same binding group as this fixity declaration. do names <- lookupLocalTcNames sig_ctxt what rdr_name @@ -1284,13 +1300,13 @@ rnSrcFixityDecl sig_ctxt = rn_decl ************************************************************************ -} -dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM () +dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt loc $ + = addErrAt (locA loc) $ vcat [ text "Duplicate" <+> what_it_is <> text "s for" <+> quotes (ppr name) , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest - $ map (getLoc . fst) + $ map (getLocA . fst) $ toList pairs) ] where @@ -1298,7 +1314,7 @@ dupSigDeclErr pairs@((L loc name, sig) :| _) misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) - = addErrAt loc $ + = addErrAt (locA loc) $ sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] defaultSigErr :: Sig GhcPs -> SDoc @@ -1311,7 +1327,9 @@ bindsInHsBootFile mbinds = hang (text "Bindings in hs-boot files are not allowed") 2 (ppr mbinds) -nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc +nonStdGuardErr :: (Outputable body, + Anno (Stmt GhcRn body) ~ SrcSpanAnnA) + => [LStmtLR GhcRn GhcRn body] -> SDoc nonStdGuardErr guards = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") 4 (interpp'SP guards) @@ -1323,8 +1341,8 @@ unusedPatBindWarn bind dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt loc $ + = addErrAt (locA loc) $ vcat [ text "Multiple minimal complete definitions" - , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs) + , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs) , text "Combine alternative minimal complete definitions with `|'" ] dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 483c6145b8..68c299a3b0 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -14,7 +14,7 @@ GHC.Rename.Env contains functions which convert RdrNames into Names. module GHC.Rename.Env ( newTopSrcBinder, - lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, lookupLocalOccRn_maybe, lookupInfoOccRn, @@ -31,8 +31,8 @@ module GHC.Rename.Env ( lookupSubBndrOcc_helper, combineChildLookupResult, -- Called by lookupChildrenExport - HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, - lookupSigCtxtOccRn, + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN, + lookupSigCtxtOccRn, lookupSigCtxtOccRnN, lookupInstDeclBndr, lookupFamInstName, lookupConstructorFields, @@ -168,7 +168,7 @@ we do not report deprecation warnings for LocalDef. See also Note [Handling of deprecations] -} -newTopSrcBinder :: Located RdrName -> RnM Name +newTopSrcBinder :: LocatedN RdrName -> RnM Name newTopSrcBinder (L loc rdr_name) | Just name <- isExact_maybe rdr_name = -- This is here to catch @@ -183,7 +183,7 @@ newTopSrcBinder (L loc rdr_name) if isExternalName name then do { this_mod <- getModule ; unless (this_mod == nameModule name) - (addErrAt loc (badOrigBinding rdr_name)) + (addErrAt (locA loc) (badOrigBinding rdr_name)) ; return name } else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" do { this_mod <- getModule @@ -192,7 +192,7 @@ newTopSrcBinder (L loc rdr_name) | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { this_mod <- getModule ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (addErrAt loc (badOrigBinding rdr_name)) + (addErrAt (locA loc) (badOrigBinding rdr_name)) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad -- @@ -210,11 +210,11 @@ newTopSrcBinder (L loc rdr_name) -- the RdrName, not from the environment. In principle, it'd be fine to -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - ; newGlobalBinder rdr_mod rdr_occ loc } + ; newGlobalBinder rdr_mod rdr_occ (locA loc) } | otherwise = do { when (isQual rdr_name) - (addErrAt loc (badQualBndrErr rdr_name)) + (addErrAt (locA loc) (badQualBndrErr rdr_name)) -- Binders should not be qualified; if they are, and with a different -- module name, we get a confusing "M.T is not in scope" error later @@ -223,11 +223,11 @@ newTopSrcBinder (L loc rdr_name) -- We are inside a TH bracket, so make an *Internal* name -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names do { uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } else do { this_mod <- getModule - ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc) - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } + ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc)) + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) } } {- @@ -285,6 +285,9 @@ lookupTopBndrRn rdr_name = lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn +lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name) +lookupLocatedTopBndrRnN = wrapLocMA lookupTopBndrRn + -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions] @@ -387,12 +390,12 @@ lookupInstDeclBndr cls what rdr doc = what <+> text "of class" <+> quotes (ppr cls) ----------------------------------------------- -lookupFamInstName :: Maybe Name -> Located RdrName - -> RnM (Located Name) +lookupFamInstName :: Maybe Name -> LocatedN RdrName + -> RnM (LocatedN Name) -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind - = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr + = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* = lookupLocatedOccRn tc_rdr @@ -988,8 +991,9 @@ we'll miss the fact that the qualified import is redundant. -} -lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedOccRn = wrapLocM lookupOccRn +lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName + -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRn = wrapLocMA lookupOccRn lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Just look in the local environment @@ -1742,16 +1746,34 @@ instance Outputable HsSigCtxt where lookupSigOccRn :: HsSigCtxt -> Sig GhcPs - -> Located RdrName -> RnM (Located Name) + -> LocatedA RdrName -> RnM (LocatedA Name) lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) +lookupSigOccRnN :: HsSigCtxt + -> Sig GhcPs + -> LocatedN RdrName -> RnM (LocatedN Name) +lookupSigOccRnN ctxt sig = lookupSigCtxtOccRnN ctxt (hsSigDoc sig) + + +-- | Lookup a name in relation to the names in a 'HsSigCtxt' +lookupSigCtxtOccRnN :: HsSigCtxt + -> SDoc -- ^ description of thing we're looking up, + -- like "type family" + -> LocatedN RdrName -> RnM (LocatedN Name) +lookupSigCtxtOccRnN ctxt what + = wrapLocMA $ \ rdr_name -> + do { mb_name <- lookupBindGroupOcc ctxt what rdr_name + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } + Right name -> return name } + -- | Lookup a name in relation to the names in a 'HsSigCtxt' lookupSigCtxtOccRn :: HsSigCtxt -> SDoc -- ^ description of thing we're looking up, -- like "type family" - -> Located RdrName -> RnM (Located Name) + -> LocatedA RdrName -> RnM (LocatedA Name) lookupSigCtxtOccRn ctxt what - = wrapLocM $ \ rdr_name -> + = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } @@ -1994,10 +2016,10 @@ lookupSyntaxNames :: [Name] -- Standard names lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then - return (map (HsVar noExtField . noLoc) std_names, emptyFVs) + return (map (HsVar noExtField . noLocA) std_names, emptyFVs) else do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } } + ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } } {- diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 1ffbc4371a..bbf52be2f8 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -20,7 +21,8 @@ free variables. -} module GHC.Rename.Expr ( - rnLExpr, rnExpr, rnStmts + rnLExpr, rnExpr, rnStmts, + AnnoBody ) where #include "HsVersions.h" @@ -183,18 +185,18 @@ rnExprs ls = rnExprs' ls emptyUniqSet -- Variables. We look up the variable and return the resulting name. rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) -rnLExpr = wrapLocFstM rnExpr +rnLExpr = wrapLocFstMA rnExpr rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) +finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions finishHsVar (L l name) = do { this_mod <- getModule ; when (nameIsLocalOrFrom this_mod name) $ checkThLocalName name - ; return (HsVar noExtField (L l name), unitFV name) } + ; return (HsVar noExtField (L (la2na l) name), unitFV name) } rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v = @@ -204,9 +206,9 @@ rnUnboundVar v = -- and let the type checker report the error return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) - else -- Fail immediately (qualified name) - do { n <- reportUnboundName v - ; return (HsVar noExtField (noLoc n), emptyFVs) } + else -- Fail immediately (qualified name) + do { n <- reportUnboundName v + ; return (HsVar noExtField (noLocA n), emptyFVs) } rnExpr (HsVar _ (L l v)) = do { dflags <- getDynFlags @@ -220,10 +222,10 @@ rnExpr (HsVar _ (L l v)) -- OverloadedLists works correctly -- Note [Empty lists] in GHC.Hs.Expr , xopt LangExt.OverloadedLists dflags - -> rnExpr (ExplicitList noExtField []) + -> rnExpr (ExplicitList noAnn []) | otherwise - -> finishHsVar (L l name) ; + -> finishHsVar (L (na2la l) name) ; Just (UnambiguousGre (FieldGreName fl)) -> let sel_name = flSelector fl in return ( HsRecFld noExtField (Unambiguous sel_name (L l v) ), unitFV sel_name) ; @@ -234,13 +236,13 @@ rnExpr (HsVar _ (L l v)) rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) -rnExpr (HsUnboundVar x v) - = return (HsUnboundVar x v, emptyFVs) +rnExpr (HsUnboundVar _ v) + = return (HsUnboundVar noExtField v, emptyFVs) -- HsOverLabel: see Note [Handling overloaded and rebindable constructs] rnExpr (HsOverLabel _ v) = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName - ; return ( mkExpandedExpr (HsOverLabel noExtField v) $ + ; return ( mkExpandedExpr (HsOverLabel noAnn v) $ HsAppType noExtField (genLHsVar from_label) hs_ty_arg , fvs ) } where @@ -263,20 +265,21 @@ rnExpr (HsOverLit x lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] ; case mb_neg of Nothing -> return (HsOverLit x lit', fvs) - Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) - , fvs ) } + Just neg -> + return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit')) + , fvs ) } rnExpr (HsApp x fun arg) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnLExpr arg ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType x fun arg) +rnExpr (HsAppType _ fun arg) = do { type_app <- xoptM LangExt.TypeApplications ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg ; (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) } + ; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) } rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -309,17 +312,19 @@ rnExpr (NegApp _ e _) rnExpr (HsGetField _ e f) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName ; (e, fv_e) <- rnLExpr e + ; let f' = rnHsFieldLabel f ; return ( mkExpandedExpr - (HsGetField noExtField e f) - (mkGetField getField e f) + (HsGetField noExtField e f') + (mkGetField getField e (fmap (unLoc . hflLabel) f')) , fv_e `plusFV` fv_getField ) } rnExpr (HsProjection _ fs) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName ; circ <- lookupOccRn compose_RDR + ; let fs' = fmap rnHsFieldLabel fs ; return ( mkExpandedExpr - (HsProjection noExtField fs) - (mkProjection getField circ fs) + (HsProjection noExtField fs') + (mkProjection getField circ (map (fmap (unLoc . hflLabel)) fs')) , unitFV circ `plusFV` fv_getField) } ------------------------------------------ @@ -364,51 +369,50 @@ rnExpr (HsLamCase x matches) = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches ; return (HsLamCase x matches', fvs_ms) } -rnExpr (HsCase x expr matches) +rnExpr (HsCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches - ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet x (L l binds) expr) +rnExpr (HsLet _ binds expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet x (L l binds') expr', fvExpr) } + ; return (HsLet noExtField binds' expr', fvExpr) } -rnExpr (HsDo x do_or_lc (L l stmts)) +rnExpr (HsDo _ do_or_lc (L l stmts)) = do { ((stmts', _), fvs) <- - rnStmtsWithPostProcessing do_or_lc rnLExpr + rnStmtsWithPostProcessing do_or_lc rnExpr postProcessStmtsForApplicativeDo stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } + ; return ( HsDo noExtField do_or_lc (L l stmts'), fvs ) } -- ExplicitList: see Note [Handling overloaded and rebindable constructs] -rnExpr (ExplicitList x exps) +rnExpr (ExplicitList _ exps) = do { (exps', fvs) <- rnExprs exps ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; if not opt_OverloadedLists - then return (ExplicitList x exps', fvs) + then return (ExplicitList noExtField exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; let rn_list = ExplicitList x exps' + ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) - hs_lit = wrapGenSpan (HsLit noExtField (HsInt noExtField lit_n)) + hs_lit = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n)) exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list] ; return ( mkExpandedExpr rn_list exp_list , fvs `plusFV` fvs') } } -rnExpr (ExplicitTuple x tup_args boxity) +rnExpr (ExplicitTuple _ tup_args boxity) = do { checkTupleSection tup_args ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args - ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } + ; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) } where - rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e - ; return (L l (Present x e'), fvs) } - rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) - , emptyFVs) + rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e + ; return (Present x e', fvs) } + rnTupArg (Missing _) = return (Missing noExtField, emptyFVs) -rnExpr (ExplicitSum x alt arity expr) +rnExpr (ExplicitSum _ alt arity expr) = do { (expr', fvs) <- rnLExpr expr - ; return (ExplicitSum x alt arity expr', fvs) } + ; return (ExplicitSum noExtField alt arity expr', fvs) } rnExpr (RecordCon { rcon_con = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) @@ -420,7 +424,7 @@ rnExpr (RecordCon { rcon_con = con_id , rcon_con = con_lname, rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where - mk_hs_var l n = HsVar noExtField (L l n) + mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } @@ -476,20 +480,20 @@ rnExpr (HsIf _ p b1 b2) fvs = plusFVs [fvs_if, unitFV ite_name] ; return (mkExpandedExpr rn_if ds_if, fvs) } } -rnExpr (HsMultiIf x alts) +rnExpr (HsMultiIf _ alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts - ; return (HsMultiIf x alts', fvs) } + ; return (HsMultiIf noExtField alts', fvs) } -rnExpr (ArithSeq x _ seq) +rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq ; if opt_OverloadedLists then do { ; (from_list_name, fvs') <- lookupSyntax fromListName - ; return (ArithSeq x (Just from_list_name) new_seq + ; return (ArithSeq noExtField (Just from_list_name) new_seq , fvs `plusFV` fvs') } else - return (ArithSeq x Nothing new_seq, fvs) } + return (ArithSeq noExtField Nothing new_seq, fvs) } {- ************************************************************************ @@ -541,7 +545,6 @@ rnExpr (HsProc x pat body) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap - {- ********************************************************************* * * Operator sections @@ -572,9 +575,9 @@ rnSection section@(SectionL x expr op) -- Note [Left and right sections] ; let rn_section = SectionL x expr' op' ds_section - | postfix_ops = HsApp noExtField op' expr' + | postfix_ops = HsApp noAnn op' expr' | otherwise = genHsApps leftSectionName - [wrapGenSpan $ HsApp noExtField op' expr'] + [wrapGenSpan $ HsApp noAnn op' expr'] ; return ( mkExpandedExpr rn_section ds_section , fvs_op `plusFV` fvs_expr) } @@ -694,6 +697,19 @@ bindNonRec will automatically do the right thing, giving us: See #18151. -} +{- +************************************************************************ +* * + Field Labels +* * +************************************************************************ +-} + +rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn) +rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label) + +rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn +rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls) {- ************************************************************************ @@ -725,14 +741,14 @@ rnCmdTop = wrapLocFstM rnCmdTop' fvCmd `plusFV` cmd_fvs) } rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) -rnLCmd = wrapLocFstM rnCmd +rnLCmd = wrapLocFstMA rnCmd rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) -rnCmd (HsCmdArrApp x arrow arg ho rtl) +rnCmd (HsCmdArrApp _ arrow arg ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) ; (arg',fvArg) <- rnLExpr arg - ; return (HsCmdArrApp x arrow' arg' ho rtl, + ; return (HsCmdArrApp noExtField arrow' arg' ho rtl, fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of @@ -755,34 +771,36 @@ rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) ; final_e <- mkOpFormRn arg1' op' fixity arg2' ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } -rnCmd (HsCmdArrForm x op f fixity cmds) +rnCmd (HsCmdArrForm _ op f fixity cmds) = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } + ; return ( HsCmdArrForm noExtField op' f fixity cmds' + , fvOp `plusFV` fvCmds) } rnCmd (HsCmdApp x fun arg) = do { (fun',fvFun) <- rnLCmd fun ; (arg',fvArg) <- rnLExpr arg ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam x matches) +rnCmd (HsCmdLam _ matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches - ; return (HsCmdLam x matches', fvMatch) } + ; return (HsCmdLam noExtField matches', fvMatch) } rnCmd (HsCmdPar x e) = do { (e', fvs_e) <- rnLCmd e ; return (HsCmdPar x e', fvs_e) } -rnCmd (HsCmdCase x expr matches) +rnCmd (HsCmdCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches - ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; return (HsCmdCase noExtField new_expr new_matches + , e_fvs `plusFV` ms_fvs) } rnCmd (HsCmdLamCase x matches) = do { (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches ; return (HsCmdLamCase x new_matches, ms_fvs) } -rnCmd (HsCmdIf x _ p b1 b2) +rnCmd (HsCmdIf _ _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 ; (b2', fvB2) <- rnLCmd b2 @@ -792,17 +810,17 @@ rnCmd (HsCmdIf x _ p b1 b2) Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name) Nothing -> (NoSyntaxExprRn, emptyFVs) - ; return (HsCmdIf x ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet x (L l binds) cmd) +rnCmd (HsCmdLet _ binds cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet x (L l binds') cmd', fvExpr) } + ; return (HsCmdLet noExtField binds' cmd', fvExpr) } -rnCmd (HsCmdDo x (L l stmts)) +rnCmd (HsCmdDo _ (L l stmts)) = do { ((stmts', _), fvs) <- - rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsCmdDo x (L l stmts'), fvs ) } + rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo noExtField (L l stmts'), fvs ) } --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are @@ -858,18 +876,18 @@ methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- -methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars +methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars +methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ _ cmd) = methodNamesLCmd cmd -methodNamesStmt (RecStmt { recS_stmts = stmts }) = +methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt {}) = emptyFVs methodNamesStmt (ParStmt {}) = emptyFVs @@ -937,35 +955,42 @@ To get a stable order we use nameSetElemsStable. See Note [Deterministic UniqFM] to learn more about nondeterminism. -} +type AnnoBody body + = ( Outputable (body GhcPs) + , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + ) + -- | Rename some Stmts -rnStmts :: Outputable (body GhcPs) +rnStmts :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> [LStmt GhcPs (Located (body GhcPs))] + -> [LStmt GhcPs (LocatedA (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) + -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing - :: Outputable (body GhcPs) + :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) -> (HsStmtContext GhcRn - -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) + -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)) -- ^ postprocess the statements - -> [LStmt GhcPs (Located (body GhcPs))] + -> [LStmt GhcPs (LocatedA (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) + -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside @@ -997,17 +1022,17 @@ postProcessStmtsForApplicativeDo ctxt stmts -- | strip the FreeVars annotations from statements noPostProcessStmts :: HsStmtContext GhcRn - -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) + -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) -rnStmtsWithFreeVars :: Outputable (body GhcPs) +rnStmtsWithFreeVars :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] + -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing) , FreeVars) -- Each Stmt body is annotated with its FreeVars, so that -- we can rearrange statements for ApplicativeDo. @@ -1023,7 +1048,7 @@ rnStmtsWithFreeVars ctxt _ [] thing_inside rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt mDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> + <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ -> do { last_stmt' <- checkLastStmt mDoExpr last_stmt ; rnStmt mDoExpr rnBody last_stmt' thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } @@ -1032,13 +1057,13 @@ rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside -- Deal with rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside | null lstmts - = setSrcSpan loc $ + = setSrcSpanA loc $ do { lstmt' <- checkLastStmt ctxt lstmt ; rnStmt ctxt rnBody lstmt' thing_inside } | otherwise = do { ((stmts1, (stmts2, thing)), fvs) - <- setSrcSpan loc $ + <- setSrcSpanA loc $ do { checkStmt ctxt lstmt ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> @@ -1067,20 +1092,20 @@ exhaustive list). How we deal with pattern match failure is context-dependent. At one point we failed to make this distinction, leading to #11216. -} -rnStmt :: Outputable (body GhcPs) +rnStmt :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of the statement - -> LStmt GhcPs (Located (body GhcPs)) + -> LStmt GhcPs (LocatedA (body GhcPs)) -- ^ The statement -> ([Name] -> RnM (thing, FreeVars)) -- ^ Rename the stuff that this statement scopes over - -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing) , FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside +rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- if isMonadCompContext ctxt then lookupStmtName ctxt returnMName @@ -1091,10 +1116,10 @@ rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside -- #15607 ; (thing, fvs3) <- thing_inside [] - ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)] + ; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside +rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside = do { (body', fv_expr) <- rnBody body ; (then_op, fvs1) <- lookupQualifiedDoStmtName ctxt thenMName @@ -1106,10 +1131,10 @@ rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside -- Here "gd" is a guard ; (thing, fvs3) <- thing_inside [] - ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] + ; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside +rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside = do { (body', fv_expr) <- rnBody body -- The binders do not scope over the expression ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName @@ -1119,19 +1144,19 @@ rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat') ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } - ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )] + ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )] , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside +rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside = rnLocalBindsAndThen binds $ \binds' bind_fvs -> do { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds') - ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) + ; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing) , fvs) } -rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside +rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName @@ -1155,7 +1180,7 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside segs -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] ; (thing, fvs_later) <- thing_inside bndrs - ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + ; let (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs fvs_later -- We aren't going to try to group RecStmts with -- ApplicativeDo, so attaching empty FVs is fine. ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) @@ -1177,7 +1202,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing @@ -1229,7 +1254,7 @@ rnParallelStmts ctxt return_op segs thing_inside rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> + <- rnStmts ctxt rnExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs @@ -1264,12 +1289,12 @@ lookupStmtNamePoly ctxt name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar noExtField (noLoc fm), unitFV fm) } + ; return (HsVar noExtField (noLocA fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where - not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs) + not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable @@ -1325,14 +1350,13 @@ type Segment stmts = (Defs, -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: Outputable (body GhcPs) => +rnRecStmtsAndThen :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) - -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments - -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] + -> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnRecStmtsAndThen ctxt rnBody s cont @@ -1362,7 +1386,7 @@ rnRecStmtsAndThen ctxt rnBody s cont collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of - (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> + (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) -> foldr (\ sig -> \ acc -> case sig of (L loc (FixSig _ s)) -> (L loc s) : acc _ -> acc) acc sigs @@ -1370,12 +1394,12 @@ collectRecStmtsFixities l = -- left-hand sides -rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv - -> LStmt GhcPs body +rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv + -> LStmt GhcPs (LocatedA (body GhcPs)) -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] + -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] @@ -1387,20 +1411,20 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body)) = do -- should the ctxt be MDo instead? (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat - return [(L loc (BindStmt noExtField pat' body), fv_pat)] + return [(L loc (BindStmt noAnn pat' body), fv_pat)] -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) +rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) +rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))), + return [(L loc (LetStmt noAnn (HsValBinds x binds')), -- Warning: this is bogus; see function invariant emptyFVs )] -- XXX Do we need to do something with the return and mfix names? -rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo @@ -1412,12 +1436,12 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) +rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt GhcPs body] - -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] +rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv + -> [LStmt GhcPs (LocatedA (body GhcPs))] + -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls) @@ -1430,28 +1454,28 @@ rn_rec_stmts_lhs fix_env stmts -- right-hand-sides -rn_rec_stmt :: (Outputable (body GhcPs)) => +rn_rec_stmt :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [Name] - -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) - -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] + -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ body noret _), _) +rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _) = do { (body', fv_expr) <- rnBody body ; (ret_op, fvs1) <- lookupQualifiedDo ctxt returnMName ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, - L loc (LastStmt noExtField body' noret ret_op))] } + L loc (LastStmt noExtField (L lb body') noret ret_op))] } -rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ body _ _), _) +rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _) = do { (body', fvs) <- rnBody body ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } + L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] } -rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) +rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat) = do { (body', fv_expr) <- rnBody body ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName @@ -1461,17 +1485,17 @@ rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat) fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op } ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt xbsrn pat' body'))] } + L loc (BindStmt xbsrn pat' (L lb body')))] } -rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) +rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) +rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' -- fixities and unused are handled above in rnRecStmtsAndThen ; let fvs = allUses du_binds ; return [(duDefs du_binds, fvs, emptyNameSet, - L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } + L loc (LetStmt noAnn (HsValBinds x binds')))] } -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _) @@ -1483,27 +1507,28 @@ rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in m rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) +rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmts :: Outputable (body GhcPs) => +rn_rec_stmts :: AnnoBody body => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [Name] - -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] - -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] + -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] + -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] rn_rec_stmts ctxt rnBody bndrs stmts = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts ; return (concat segs_s) } --------------------------------------------- -segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn - -> Stmt GhcRn body - -> [Segment (LStmt GhcRn body)] -> FreeVars - -> ([LStmt GhcRn body], FreeVars) +segmentRecStmts :: AnnoBody body + => SrcSpan -> HsStmtContext GhcRn + -> Stmt GhcRn (LocatedA (body GhcRn)) + -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> FreeVars + -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later | null segs @@ -1518,8 +1543,8 @@ segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later -- used 'after' the RecStmt | otherwise - = ([ L loc $ - empty_rec_stmt { recS_stmts = ss + = ([ L (noAnnSrcSpan loc) $ + empty_rec_stmt { recS_stmts = noLocA ss , recS_later_ids = nameSetElemsStable (defs `intersectNameSet` fvs_later) , recS_rec_ids = nameSetElemsStable @@ -1636,12 +1661,12 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs) not_needed (defs,_,_,_) = disjointNameSet defs uses ---------------------------------------------------- -segsToStmts :: Stmt GhcRn body +segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn)) -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt GhcRn body]] + -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]] -- Each Segment has a non-empty list of Stmts -> FreeVars -- Free vars used 'later' - -> ([LStmt GhcRn body], FreeVars) + -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later @@ -1651,7 +1676,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss | otherwise = L (getLoc (head ss)) rec_stmt - rec_stmt = empty_rec_stmt { recS_stmts = ss + rec_stmt = empty_rec_stmt { recS_stmts = noLocA ss , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds } -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] @@ -2019,14 +2044,14 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do pvars = nameSetElemsStable pvarset -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] pat = mkBigLHsVarPatTup pvars - tup = mkBigLHsVarTup pvars + tup = mkBigLHsVarTup pvars noExtField (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset (mb_ret, fvs1) <- if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do (ret, _) <- lookupQualifiedDoExpr ctxt returnMName - let expr = HsApp noExtField (noLoc ret) tup + let expr = HsApp noComments (noLocA ret) tup return (expr, emptyFVs) return ( ApplicativeArgMany { xarg_app_arg_many = noExtField @@ -2178,10 +2203,10 @@ splitSegment stmts _other -> (stmts,[]) slurpIndependentStmts - :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] - -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts - , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts - , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) + :: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] ) slurpIndependentStmts stmts = go [] [] emptyNameSet stmts where -- If we encounter a BindStmt that doesn't depend on a previous BindStmt @@ -2234,7 +2259,7 @@ mkApplicativeStmt ctxt args need_join body_stmts ; return (Just join_op, fvs) } else return (Nothing, emptyNameSet) - ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField + ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField (zip (fmap_op : repeat ap_op) args) mb_join ; return ( applicative_stmt : body_stmts @@ -2296,9 +2321,9 @@ emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or ' emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: Outputable (body GhcPs) => HsStmtContext GhcRn - -> LStmt GhcPs (Located (body GhcPs)) - -> RnM (LStmt GhcPs (Located (body GhcPs))) +checkLastStmt :: AnnoBody body => HsStmtContext GhcRn + -> LStmt GhcPs (LocatedA (body GhcPs)) + -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt) = case ctxt of ListComp -> check_comp @@ -2327,7 +2352,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext GhcRn - -> LStmt GhcPs (Located (body GhcPs)) + -> LStmt GhcPs (LocatedA (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags @@ -2354,7 +2379,7 @@ emptyInvalid = NotValid Outputable.empty okStmt, okDoStmt, okCompStmt, okParStmt :: DynFlags -> HsStmtContext GhcRn - -> Stmt GhcPs (Located (body GhcPs)) -> Validity + -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to a generic error message @@ -2371,7 +2396,7 @@ okStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity +okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity okPatGuardStmt stmt = case stmt of BodyStmt {} -> IsValid @@ -2382,8 +2407,8 @@ okPatGuardStmt stmt ------------- okParStmt dflags ctxt stmt = case stmt of - LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid - _ -> okStmt dflags ctxt stmt + LetStmt _ (HsIPBinds {}) -> emptyInvalid + _ -> okStmt dflags ctxt stmt ---------------- okDoStmt dflags ctxt stmt @@ -2414,7 +2439,7 @@ okCompStmt dflags _ stmt ApplicativeStmt {} -> emptyInvalid --------- -checkTupleSection :: [LHsTupArg GhcPs] -> RnM () +checkTupleSection :: [HsTupArg GhcPs] -> RnM () checkTupleSection args = do { tuple_section <- xoptM LangExt.TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } @@ -2504,10 +2529,10 @@ getMonadFailOp ctxt arg_name <- newSysName arg_lit let arg_syn_expr = nlHsVar arg_name body :: LHsExpr GhcRn = - nlHsApp (noLoc failExpr) - (nlHsApp (noLoc $ fromStringExpr) arg_syn_expr) + nlHsApp (noLocA failExpr) + (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr) let failAfterFromStringExpr :: HsExpr GhcRn = - unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body + unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = mkSyntaxExpr failAfterFromStringExpr return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) @@ -2525,7 +2550,7 @@ genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn genHsApps fun args = foldl genHsApp (genHsVar fun) args genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg +genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg genLHsVar :: Name -> LHsExpr GhcRn genLHsVar nm = wrapGenSpan $ genHsVar nm @@ -2539,10 +2564,10 @@ genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText -wrapGenSpan :: a -> Located a +wrapGenSpan :: a -> LocatedAn an a -- Wrap something in a "generatedSrcSpan" -- See Note [Rebindable syntax and HsExpansion] -wrapGenSpan x = L generatedSrcSpan x +wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x -- | Build a 'HsExpansion' out of an extension constructor, -- and the two components of the expansion: original and @@ -2594,8 +2619,9 @@ mkProjection _ _ [] = panic "mkProjection: The impossible happened" -- e.g. Suppose an update like foo.bar = 1. -- We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1). mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn) -mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds)), hsRecFieldArg = arg } )) +mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds')), hsRecFieldArg = arg } )) = let { + ; flds = map (fmap (unLoc . hflLabel)) flds' ; final = last flds -- quux ; fields = init flds -- [foo, bar, baz] ; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow. @@ -2618,6 +2644,9 @@ rnHsUpdProjs us = do pure (u, plusFVs fvs) where rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars) - rnRecUpdProj (L l (HsRecField fs arg pun)) + rnRecUpdProj (L l (HsRecField _ fs arg pun)) = do { (arg, fv) <- rnLExpr arg - ; return $ (L l (HsRecField { hsRecFieldLbl = fs, hsRecFieldArg = arg, hsRecPun = pun}), fv) } + ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn + , hsRecFieldLbl = fmap rnFieldLabelStrings fs + , hsRecFieldArg = arg + , hsRecPun = pun}), fv) } diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot index cc52d45e82..58f6bbc874 100644 --- a/compiler/GHC/Rename/Expr.hs-boot +++ b/compiler/GHC/Rename/Expr.hs-boot @@ -1,17 +1,27 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} module GHC.Rename.Expr where import GHC.Types.Name import GHC.Hs import GHC.Types.Name.Set ( FreeVars ) import GHC.Tc.Types -import GHC.Types.SrcLoc ( Located ) import GHC.Utils.Outputable ( Outputable ) +rnExpr :: HsExpr GhcPs + -> RnM (HsExpr GhcRn, FreeVars) + rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) +type AnnoBody body + = ( Outputable (body GhcPs) + , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + ) rnStmts :: --forall thing body. - Outputable (body GhcPs) => HsStmtContext GhcRn - -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) - -> [LStmt GhcPs (Located (body GhcPs))] + AnnoBody body => HsStmtContext GhcRn + -> (body GhcPs -> RnM (body GhcRn, FreeVars)) + -> [LStmt GhcPs (LocatedA (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) + -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index 3d8a3615c1..e45f3a5cdb 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -181,7 +181,7 @@ lookupFixityRn_help' name occ doc = text "Checking fixity for" <+> ppr name --------------- -lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc -- | Look up the fixity of a (possibly ambiguous) occurrence of a record field diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 8634d5939f..a7f28b69cc 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -34,7 +36,7 @@ module GHC.Rename.HsType ( extractHsTysRdrTyVars, extractRdrKindSigVars, extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars, - nubL + nubL, nubN ) where import GHC.Prelude @@ -47,7 +49,7 @@ import GHC.Hs import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext , mapFvRn, pprHsDocContext, bindLocalNamesFV - , typeAppErr, newLocalBndrRn, checkDupRdrNames + , typeAppErr, newLocalBndrRn, checkDupRdrNamesN , checkShadowedRdrNames ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) @@ -155,7 +157,7 @@ rnHsPatSigType scoping ctx sig_ty thing_inside ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty) ; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty) ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars - ; let nwc_rdrs = nubL nwc_rdrs' + ; let nwc_rdrs = nubN nwc_rdrs' implicit_bndrs = case scoping of AlwaysBind -> tv_rdrs NeverBind -> [] @@ -228,7 +230,7 @@ rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of (res, fvs') <- thing_inside sig_ty return (res, fvs `plusFV` fvs') -rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs +rnWcBody :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs -> RnM ([Name], LHsType GhcRn, FreeVars) rnWcBody ctxt nwc_rdrs hs_ty = do { nwcs <- mapM newLocalBndrRn nwc_rdrs @@ -241,7 +243,7 @@ rnWcBody ctxt nwc_rdrs hs_ty ; return (nwcs, hs_ty', fvs) } where rn_lty env (L loc hs_ty) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { (hs_ty', fvs) <- rn_ty env hs_ty ; return (L loc hs_ty', fvs) } @@ -260,7 +262,7 @@ rnWcBody ctxt nwc_rdrs hs_ty , Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 - ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 + ; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1 ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExtField @@ -335,7 +337,7 @@ extraConstraintWildCardsAllowed env -- FreeKiTyVars in the argument and returns them in a separate list. -- When the extension is disabled, the function returns the argument -- and empty list. See Note [Renaming named wild cards] -partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars) +partition_nwcs :: FreeKiTyVars -> RnM ([LocatedN RdrName], FreeKiTyVars) partition_nwcs free_vars = do { wildcards_enabled <- xoptM LangExt.NamedWildCards ; return $ @@ -343,7 +345,7 @@ partition_nwcs free_vars then partition is_wildcard free_vars else ([], free_vars) } where - is_wildcard :: Located RdrName -> Bool + is_wildcard :: LocatedN RdrName -> Bool is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) {- Note [Renaming named wild cards] @@ -373,7 +375,7 @@ rnHsSigType :: HsDocContext -- that cannot have wildcards rnHsSigType ctx level (L loc sig_ty@(HsSig { sig_bndrs = outer_bndrs, sig_body = body })) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { traceRn "rnHsSigType" (ppr sig_ty) ; case outer_bndrs of HsOuterExplicit{} -> checkPolyKinds env sig_ty @@ -399,7 +401,7 @@ rnImplicitTvOccs :: Maybe assoc -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside - = do { let implicit_vs = nubL implicit_vs_with_dups + = do { let implicit_vs = nubN implicit_vs_with_dups ; traceRn "rnImplicitTvOccs" $ vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ] @@ -407,7 +409,8 @@ rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside -- Use the currently set SrcSpan as the new source location for each Name. -- See Note [Source locations for implicitly bound type variables]. ; loc <- getSrcSpanM - ; vars <- mapM (newTyVarNameRn mb_assoc . L loc . unLoc) implicit_vs + ; let loc' = noAnnSrcSpan loc + ; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs ; bindLocalNamesFV vars $ thing_inside vars } @@ -589,7 +592,7 @@ rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta -------------- rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsTyKi env (L loc ty) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { (ty', fvs) <- rnHsTyKi env ty ; return (L loc ty', fvs) } @@ -622,10 +625,10 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name - ; return (HsTyVar noExtField ip (L loc name), unitFV name) } + ; return (HsTyVar noAnn ip (L loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) - = setSrcSpan (getLoc l_op) $ + = setSrcSpan (getLocA l_op) $ do { (l_op', fvs1) <- rnHsTyOp env ty l_op ; fix <- lookupTyFixityRn l_op' ; (ty1', fvs2) <- rnLHsTyKi env ty1 @@ -635,11 +638,11 @@ rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) rnHsTyKi env (HsParTy _ ty) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsParTy noExtField ty', fvs) } + ; return (HsParTy noAnn ty', fvs) } -rnHsTyKi env (HsBangTy _ b ty) +rnHsTyKi env (HsBangTy x b ty) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsBangTy noExtField b ty', fvs) } + ; return (HsBangTy x b ty', fvs) } rnHsTyKi env ty@(HsRecTy _ flds) = do { let ctxt = rtke_ctxt env @@ -661,35 +664,35 @@ rnHsTyKi env (HsFunTy u mult ty1 ty2) ; return (HsFunTy u mult' ty1' ty2' , plusFVs [fvs1, fvs2, w_fvs]) } -rnHsTyKi env listTy@(HsListTy _ ty) +rnHsTyKi env listTy@(HsListTy x ty) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env listTy)) ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsListTy noExtField ty', fvs) } + ; return (HsListTy x ty', fvs) } -rnHsTyKi env (HsKindSig _ ty k) +rnHsTyKi env (HsKindSig x ty k) = do { kind_sigs_ok <- xoptM LangExt.KindSignatures ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) ; (ty', lhs_fvs) <- rnLHsTyKi env ty ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k - ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) } + ; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) +rnHsTyKi env tupleTy@(HsTupleTy x tup_con tys) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env tupleTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsTupleTy noExtField tup_con tys', fvs) } + ; return (HsTupleTy x tup_con tys', fvs) } -rnHsTyKi env sumTy@(HsSumTy _ tys) +rnHsTyKi env sumTy@(HsSumTy x tys) = do { data_kinds <- xoptM LangExt.DataKinds ; when (not data_kinds && isRnKindLevel env) (addErr (dataKindsErr env sumTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsSumTy noExtField tys', fvs) } + ; return (HsSumTy x tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412) rnHsTyKi env tyLit@(HsTyLit _ t) @@ -715,10 +718,10 @@ rnHsTyKi env (HsAppKindTy l ty k) ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi env t@(HsIParamTy _ n ty) +rnHsTyKi env t@(HsIParamTy x n ty) = do { notInKinds env t ; (ty', fvs) <- rnLHsTyKi env ty - ; return (HsIParamTy noExtField n ty', fvs) } + ; return (HsIParamTy x n ty', fvs) } rnHsTyKi _ (HsStarTy _ isUni) = return (HsStarTy noExtField isUni, emptyFVs) @@ -726,9 +729,9 @@ rnHsTyKi _ (HsStarTy _ isUni) rnHsTyKi _ (HsSpliceTy _ sp) = rnSpliceType sp -rnHsTyKi env (HsDocTy _ ty haddock_doc) +rnHsTyKi env (HsDocTy x ty haddock_doc) = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsDocTy noExtField ty' haddock_doc, fvs) } + ; return (HsDocTy x ty' haddock_doc, fvs) } -- See Note [Renaming HsCoreTys] rnHsTyKi env (XHsType ty) @@ -763,9 +766,9 @@ rnHsTyKi env (HsWildCardTy _) rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs) -rnHsArrow _env (HsLinearArrow u) = return (HsLinearArrow u, emptyFVs) -rnHsArrow env (HsExplicitMult u p) - = (\(mult, fvs) -> (HsExplicitMult u mult, fvs)) <$> rnLHsTyKi env p +rnHsArrow _env (HsLinearArrow u a) = return (HsLinearArrow u a, emptyFVs) +rnHsArrow env (HsExplicitMult u a p) + = (\(mult, fvs) -> (HsExplicitMult u a mult, fvs)) <$> rnLHsTyKi env p {- Note [Renaming HsCoreTys] @@ -807,7 +810,7 @@ rnTyVar env rdr_name ; checkNamedWildCard env name ; return name } -rnLTyVar :: Located RdrName -> RnM (Located Name) +rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name) -- Called externally; does not deal with wildcards rnLTyVar (L loc rdr_name) = do { tyvar <- lookupTypeOccRn rdr_name @@ -815,8 +818,8 @@ rnLTyVar (L loc rdr_name) -------------- rnHsTyOp :: Outputable a - => RnTyKiEnv -> a -> Located RdrName - -> RnM (Located Name, FreeVars) + => RnTyKiEnv -> a -> LocatedN RdrName + -> RnM (LocatedN Name, FreeVars) rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op @@ -959,7 +962,7 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside ; let -- See Note [bindHsQTyVars examples] for what -- all these various things are doing - bndrs, implicit_kvs :: [Located RdrName] + bndrs, implicit_kvs :: [LocatedN RdrName] bndrs = map hsLTyVarLocName hs_tv_bndrs implicit_kvs = filterFreeVarsToBind bndrs $ bndr_kv_occs ++ body_kv_occs @@ -1000,11 +1003,19 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside -- -- class C (a :: j) (b :: k) where -- ^^^^^^^^^^^^^^^ - bndrs_loc = case map getLoc hs_tv_bndrs ++ map getLoc body_kv_occs of + bndrs_loc = case map get_bndr_loc hs_tv_bndrs ++ map getLocA body_kv_occs of [] -> panic "bindHsQTyVars.bndrs_loc" [loc] -> loc (loc:locs) -> loc `combineSrcSpans` last locs + -- The in-tree API annotations extend the LHsTyVarBndr location to + -- include surrounding parens. for error messages to be + -- compatible, we recreate the location from the contents + get_bndr_loc :: LHsTyVarBndr () GhcPs -> SrcSpan + get_bndr_loc (L _ (UserTyVar _ _ ln)) = getLocA ln + get_bndr_loc (L _ (KindedTyVar _ _ ln lk)) + = combineSrcSpans (getLocA ln) (getLocA lk) + {- Note [bindHsQTyVars examples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1127,7 +1138,7 @@ an LHsQTyVars can be semantically significant. As a result, we suppress -Wunused-foralls warnings in exactly one place: in bindHsQTyVars. -} -bindHsOuterTyVarBndrs :: OutputableBndrFlag flag +bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed => HsDocContext -> Maybe assoc -- ^ @'Just' _@ => an associated type decl @@ -1157,10 +1168,10 @@ bindHsForAllTelescope doc tele thing_inside = case tele of HsForAllVis { hsf_vis_bndrs = bndrs } -> bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> - thing_inside $ mkHsForAllVisTele bndrs' + thing_inside $ mkHsForAllVisTele noAnn bndrs' HsForAllInvis { hsf_invis_bndrs = bndrs } -> bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' -> - thing_inside $ mkHsForAllInvisTele bndrs' + thing_inside $ mkHsForAllInvisTele noAnn bndrs' -- | Should GHC warn if a quantified type variable goes unused? Usually, the -- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we @@ -1175,7 +1186,7 @@ instance Outputable WarnUnusedForalls where WarnUnusedForalls -> "WarnUnusedForalls" NoWarnUnusedForalls -> "NoWarnUnusedForalls" -bindLHsTyVarBndrs :: (OutputableBndrFlag flag) +bindLHsTyVarBndrs :: (OutputableBndrFlag flag 'Renamed) => HsDocContext -> WarnUnusedForalls -> Maybe a -- Just _ => an associated type decl @@ -1184,7 +1195,7 @@ bindLHsTyVarBndrs :: (OutputableBndrFlag flag) -> RnM (b, FreeVars) bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; checkDupRdrNames tv_names_w_loc + ; checkDupRdrNamesN tv_names_w_loc ; go tv_bndrs thing_inside } where tv_names_w_loc = map hsLTyVarLocName tv_bndrs @@ -1223,7 +1234,7 @@ bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind)) ; return (b, fvs1 `plusFV` fvs2) } newTyVarNameRn :: Maybe a -- associated class - -> Located RdrName -> RnM Name + -> LocatedN RdrName -> RnM Name newTyVarNameRn mb_assoc lrdr@(L _ rdr) = do { rdr_env <- getLocalRdrEnv ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of @@ -1260,7 +1271,7 @@ rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) = do { let new_names = map (fmap (lookupField fl_env)) names ; (new_ty, fvs) <- rnLHsTyKi env ty - ; return (L l (ConDeclField noExtField new_names new_ty haddock_doc) + ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc) , fvs) } lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn @@ -1301,7 +1312,7 @@ precedence and does not require rearrangement. --------------- -- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: Located Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn +mkHsOpTyRn :: LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) mkHsOpTyRn op1 fix1 ty1 (L loc2 (HsOpTy _ ty21 op2 ty22)) @@ -1312,9 +1323,9 @@ mkHsOpTyRn op1 _ ty1 ty2 -- Default case, no rearrangment = return (HsOpTy noExtField ty1 op1 ty2) --------------- -mk_hs_op_ty :: Located Name -> Fixity -> LHsType GhcRn - -> Located Name -> Fixity -> LHsType GhcRn - -> LHsType GhcRn -> SrcSpan +mk_hs_op_ty :: LocatedN Name -> Fixity -> LHsType GhcRn + -> LocatedN Name -> Fixity -> LHsType GhcRn + -> LHsType GhcRn -> SrcSpanAnnA -> RnM (HsType GhcRn) mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (NormalOp (unLoc op1),fix1) @@ -1323,7 +1334,7 @@ mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2 | associate_right = return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) new_ty <- mkHsOpTyRn op1 fix1 ty1 ty21 - ; return (noLoc new_ty `op2ty` ty22) } + ; return (noLocA new_ty `op2ty` ty22) } where lhs `op1ty` rhs = HsOpTy noExtField lhs op1 rhs lhs `op2ty` rhs = HsOpTy noExtField lhs op2 rhs @@ -1347,7 +1358,7 @@ mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 new_e <- mkOpAppRn e12 op2 fix2 e2 return (OpApp fix1 e11 op1 (L loc' new_e)) where - loc'= combineLocs e12 e2 + loc'= combineLocsA e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- @@ -1361,7 +1372,7 @@ mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 return (NegApp noExtField (L loc' new_e) neg_name) where - loc' = combineLocs neg_arg e2 + loc' = combineLocsA neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- @@ -1417,8 +1428,7 @@ right_op_ok _ _ -- Parser initially makes negation bind more tightly than any other operator -- And "deriving" code should respect this (use HsPar if not) -mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) - -> RnM (HsExpr (GhcPass id)) +mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn) mkNegAppRn neg_arg neg_name = ASSERT( not_op_app (unLoc neg_arg) ) return (NegApp noExtField neg_arg neg_name) @@ -1446,7 +1456,7 @@ mkOpFormRn a1@(L loc | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExtField op1 f (Just fix1) - [a11, L loc (HsCmdTop [] (L loc new_c))]) + [a11, L loc (HsCmdTop [] (L (noAnnSrcSpan loc) new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1457,7 +1467,7 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment -------------------------------------- -mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn +mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn) mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2 @@ -1514,7 +1524,7 @@ checkPrecMatch op (MG { mg_alts = (L _ ms) }) check (L _ (Match { m_pats = (L l1 p1) : (L l2 p2) : _ })) - = setSrcSpan (combineSrcSpans l1 l2) $ + = setSrcSpan (locA $ combineSrcSpansA l1 l2) $ do checkPrec op p1 False checkPrec op p2 True @@ -1622,7 +1632,7 @@ unexpectedPatSigTypeErr ty badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) - = setSrcSpan loc $ addErr $ + = setSrcSpanA loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) 2 (text "Perhaps you intended to use KindSignatures") @@ -1635,12 +1645,12 @@ dataKindsErr env thing pp_what | isRnKindLevel env = text "kind" | otherwise = text "type" -warnUnusedForAll :: OutputableBndrFlag flag +warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ - addWarnAt (Reason Opt_WarnUnusedForalls) loc $ + addWarnAt (Reason Opt_WarnUnusedForalls) (locA loc) $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , inHsDocContext doc ] @@ -1805,7 +1815,7 @@ type checking. While viable, this would mean we'd end up accepting this: -- These lists are guaranteed to preserve left-to-right ordering of -- the types the variables were extracted from. See also -- Note [Ordering of implicit variables]. -type FreeKiTyVars = [Located RdrName] +type FreeKiTyVars = [LocatedN RdrName] -- | Filter out any type and kind variables that are already in scope in the -- the supplied LocalRdrEnv. Note that this includes named wildcards, which @@ -1962,7 +1972,7 @@ extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars -extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc +extract_hs_arrow (HsExplicitMult _ _ p) acc = extract_lty p acc extract_hs_arrow _ acc = acc extract_hs_for_all_telescope :: HsForAllTelescope GhcPs @@ -2013,7 +2023,7 @@ extract_hs_tv_bndrs_kvs tv_bndrs = foldr extract_lty [] [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs] -extract_tv :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars +extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc = if isRdrTyVar (unLoc tv) then tv:acc else acc @@ -2030,9 +2040,12 @@ extract_tv tv acc = -- relies on to maintain the left-to-right ordering of implicitly quantified -- type variables. -- See Note [Ordering of implicit variables]. -nubL :: Eq a => [Located a] -> [Located a] +nubL :: Eq a => [GenLocated l a] -> [GenLocated l a] nubL = nubBy eqLocated +nubN :: Eq a => [LocatedN a] -> [LocatedN a] +nubN = nubBy eqLocated + -- | Filter out any potential implicit binders that are either -- already in scope, or are explicitly bound in the binder. filterFreeVarsToBind :: FreeKiTyVars diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 667c5d0eff..4d6734ae38 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -30,7 +30,7 @@ import GHC.Rename.HsType import GHC.Rename.Bind import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames - , checkDupRdrNames, bindLocalNamesFV + , checkDupRdrNamesN, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns , extendTyVarEnvFVRn, newLocalBndrsRn , withHsDocContext, noNestedForallsContextsErr @@ -241,8 +241,8 @@ addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv -- but there doesn't seem anywhere very logical to put it. addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } -rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) -rnList f xs = mapFvRn (wrapLocFstM f) xs +rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstMA f) xs {- ********************************************************* @@ -266,9 +266,9 @@ rnSrcWarnDecls _ [] rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups - in addErrAt loc (dupWarnDecl lrdr' rdr)) + in addErrAt (locA loc) (dupWarnDecl lrdr' rdr)) warn_rdr_dups - ; pairs_s <- mapM (addLocM rn_deprec) decls + ; pairs_s <- mapM (addLocMA rn_deprec) decls ; return (WarnSome ((concat pairs_s))) } where decls = concatMap (wd_warnings . unLoc) decls' @@ -286,18 +286,18 @@ rnSrcWarnDecls bndr_set decls' warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls -findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] +findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) -- look for duplicates among the OccNames; -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements -dupWarnDecl :: Located RdrName -> RdrName -> SDoc +dupWarnDecl :: LocatedN RdrName -> RdrName -> SDoc -- Located RdrName -> DeprecDecl RdrName -> SDoc dupWarnDecl d rdr_name = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr (getLoc d)] + text "also at " <+> ppr (getLocA d)] {- ********************************************************* @@ -313,13 +313,16 @@ rnAnnDecl ann@(HsAnnotation _ s provenance expr) do { (provenance', provenance_fvs) <- rnAnnProvenance provenance ; (expr', expr_fvs) <- setStage (Splice Untyped) $ rnLExpr expr - ; return (HsAnnotation noExtField s provenance' expr', + ; return (HsAnnotation noAnn s provenance' expr', provenance_fvs `plusFV` expr_fvs) } -rnAnnProvenance :: AnnProvenance RdrName - -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance :: AnnProvenance GhcPs + -> RnM (AnnProvenance GhcRn, FreeVars) rnAnnProvenance provenance = do - provenance' <- traverse lookupTopBndrRn provenance + provenance' <- case provenance of + ValueAnnProvenance n -> ValueAnnProvenance <$> lookupLocatedTopBndrRnN n + TypeAnnProvenance n -> TypeAnnProvenance <$> lookupLocatedTopBndrRnN n + ModuleAnnProvenance -> return ModuleAnnProvenance return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) {- @@ -348,7 +351,7 @@ rnDefaultDecl (DefaultDecl _ tys) rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv - ; name' <- lookupLocatedTopBndrRn name + ; name' <- lookupLocatedTopBndrRnN name ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty -- Mark any PackageTarget style imports as coming from the current package @@ -453,7 +456,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonadInstances refURL | cls == applicativeClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -468,7 +471,7 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monadClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -499,7 +502,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- checkCanonicalMonoidInstances refURL | cls == semigroupClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -510,7 +513,7 @@ checkCanonicalInstances cls poly_ty mbinds = do _ -> return () | cls == monoidClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ case mbind of FunBind { fun_id = L _ name , fun_matches = mg } @@ -529,7 +532,7 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] , m_grhss = grhss })])} | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss - , EmptyLocalBinds _ <- unLoc lbinds + , EmptyLocalBinds _ <- lbinds , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) isAliasMG _ = Nothing @@ -594,7 +597,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds eith_cls = case hsTyGetAppHead_maybe head_ty' of Just (L _ cls) -> Right cls Nothing -> Left - ( getLoc head_ty' + ( getLocA head_ty' , hang (text "Illegal head of an instance declaration:" <+> quotes (ppr head_ty')) 2 (vcat [ text "Instance heads must be of the form" @@ -733,7 +736,7 @@ rnFamEqn doc atfi extra_kvars rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc)) rn_outer_bndrs - groups :: [NonEmpty (Located RdrName)] + groups :: [NonEmpty (LocatedN RdrName)] groups = equivClasses cmpLocated pat_kity_vars ; nms_dups <- mapM (lookupOccRn . unLoc) $ [ tv | (tv :| (_:_)) <- groups ] @@ -769,7 +772,7 @@ rnFamEqn doc atfi extra_kvars -> eqn_fvs _ -> eqn_fvs `addOneFV` unLoc tycon' - ; return (FamEqn { feqn_ext = noExtField + ; return (FamEqn { feqn_ext = noAnn , feqn_tycon = tycon' -- Note [Wildcards in family instances] , feqn_bndrs = rn_outer_bndrs' @@ -802,7 +805,7 @@ rnFamEqn doc atfi extra_kvars -- -- type instance F a b c = Either a b -- ^^^^^ - lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLoc extra_kvars of + lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of [] -> panic "rnFamEqn.lhs_loc" [loc] -> loc (loc:locs) -> loc `combineSrcSpans` last locs @@ -817,9 +820,9 @@ rnFamEqn doc atfi extra_kvars rnTyFamInstDecl :: AssocTyFamInfo -> TyFamInstDecl GhcPs -> RnM (TyFamInstDecl GhcRn, FreeVars) -rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn }) +rnTyFamInstDecl atfi (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn }) = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn - ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } + ; return (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn' }, fvs) } -- | Tracks whether we are renaming: -- @@ -903,8 +906,8 @@ rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl -> Name -- Class -> [Name] - -> [Located (decl GhcPs)] - -> RnM ([Located (decl GhcRn)], FreeVars) + -> [LocatedA (decl GhcPs)] + -> RnM ([LocatedA (decl GhcRn)], FreeVars) -- Used for data and type family defaults in a class decl -- and the family instance declarations in an instance -- @@ -1162,11 +1165,11 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap) (text "Standalone-derived instance head") (getLHsInstDeclHead $ dropWildCards ty') ; warnNoDerivStrat mds' loc - ; return (DerivDecl noExtField ty' mds' overlap, fvs) } + ; return (DerivDecl noAnn ty' mds' overlap, fvs) } where ctxt = DerivDeclCtx inf_err = Just (text "Inferred type variables are not allowed") - loc = getLoc nowc_ty + loc = getLocA nowc_ty nowc_ty = dropWildCards ty standaloneDerivErr :: SDoc @@ -1198,7 +1201,7 @@ rnHsRuleDecl (HsRule { rd_name = rule_name , rd_lhs = lhs , rd_rhs = rhs }) = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs - ; checkDupRdrNames rdr_names_w_loc + ; checkDupRdrNamesN rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc ; let doc = RuleCtx (snd $ unLoc rule_name) @@ -1215,7 +1218,7 @@ rnHsRuleDecl (HsRule { rd_name = rule_name , rd_lhs = lhs' , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } where - get_var :: RuleBndr GhcPs -> Located RdrName + get_var :: RuleBndr GhcPs -> LocatedN RdrName get_var (RuleBndrSig _ v _) = v get_var (RuleBndr _ v) = v @@ -1229,13 +1232,13 @@ bindRuleTmVars doc tyvs vars names thing_inside where go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> - thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') + thing_inside (L l (RuleBndr noAnn (L loc n)) : vars') go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' -> - thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') + thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) @@ -1475,10 +1478,10 @@ rnTyClDecls :: [TyClGroup GhcPs] -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds = do { -- Rename the type/class, instance, and role declaraations - ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds) + ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds) ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) - ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) + ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) -- Do SCC analysis on the type/class decls @@ -1561,7 +1564,7 @@ rnStandaloneKindSignatures tc_names kisigs = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs get_name = standaloneKindSigName . unLoc ; mapM_ dupKindSig_Err dup_kisigs - ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups + ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups } rnStandaloneKindSignature @@ -1571,7 +1574,7 @@ rnStandaloneKindSignature rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr - ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v + ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v ; let doc = StandaloneKindSigCtx (ppr v) ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) @@ -1639,19 +1642,19 @@ rnRoleAnnots tc_names role_annots let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots get_name = roleAnnotDeclName . unLoc ; mapM_ dupRoleAnnotErr dup_annots - ; mapM (wrapLocM rn_role_annot1) no_dups } + ; mapM (wrapLocMA rn_role_annot1) no_dups } where rn_role_annot1 (RoleAnnotDecl _ tycon roles) = do { -- the name is an *occurrence*, but look it up only in the -- decls defined in this group (see #10263) - tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) - (text "role annotation") - tycon + tycon' <- lookupSigCtxtOccRnN (RoleAnnotCtxt tc_names) + (text "role annotation") + tycon ; return $ RoleAnnotDecl noExtField tycon' roles } dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list - = addErrAt loc $ + = addErrAt (locA loc) $ hang (text "Duplicate role annotations for" <+> quotes (ppr $ roleAnnotDeclName first_decl) <> colon) 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) @@ -1660,13 +1663,13 @@ dupRoleAnnotErr list ((L loc first_decl) :| _) = sorted_list pp_role_annot (L loc decl) = hang (ppr decl) - 4 (text "-- written at" <+> ppr loc) + 4 (text "-- written at" <+> ppr (locA loc)) - cmp_loc = SrcLoc.leftmost_smallest `on` getLoc + cmp_loc = SrcLoc.leftmost_smallest `on` getLocA dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list - = addErrAt loc $ + = addErrAt (locA loc) $ hang (text "Duplicate standalone kind signatures for" <+> quotes (ppr $ standaloneKindSigName first_decl) <> colon) 2 (vcat $ map pp_kisig $ NE.toList sorted_list) @@ -1675,9 +1678,9 @@ dupKindSig_Err list ((L loc first_decl) :| _) = sorted_list pp_kisig (L loc decl) = - hang (ppr decl) 4 (text "-- written at" <+> ppr loc) + hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) - cmp_loc = SrcLoc.leftmost_smallest `on` getLoc + cmp_loc = SrcLoc.leftmost_smallest `on` getLocA {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1760,7 +1763,7 @@ rnTyClDecl (FamDecl { tcdFam = fam }) rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs }) - = do { tycon' <- lookupLocatedTopBndrRn tycon + = do { tycon' <- lookupLocatedTopBndrRnN tycon ; let kvs = extractHsTyRdrTyVarsKindVars rhs doc = TySynCtx tycon ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) @@ -1776,7 +1779,7 @@ rnTyClDecl (DataDecl tcdFixity = fixity, tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data , dd_kindSig = kind_sig} }) - = do { tycon' <- lookupLocatedTopBndrRn tycon + = do { tycon' <- lookupLocatedTopBndrRnN tycon ; let kvs = extractDataDefnKindVars defn doc = TyDataCtx tycon ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) @@ -1797,7 +1800,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs}) - = do { lcls' <- lookupLocatedTopBndrRn lcls + = do { lcls' <- lookupLocatedTopBndrRnN lcls ; let cls' = unLoc lcls' kvs = [] -- No scoped kind vars except those in -- kind signatures on the tyvars @@ -1824,7 +1827,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig _ False ops _) <- sigs , op <- ops] - ; checkDupRdrNames sig_rdr_names_w_locs + ; checkDupRdrNamesN sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't @@ -1918,7 +1921,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ext = noExtField + ; return ( HsDataDefn { dd_ext = noAnn , dd_ND = new_or_data, dd_cType = cType , dd_ctxt = context', dd_kindSig = m_sig' , dd_cons = condecls' @@ -1930,12 +1933,12 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType (L _ (ConDeclGADT {})) : _ -> False _ -> True - rn_derivs (L loc ds) + rn_derivs ds = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) multipleDerivClausesErr ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (L loc ds', fvs) } + ; return (ds', fvs) } warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan @@ -2025,10 +2028,10 @@ rnLDerivStrategy doc mds thing_inside failWith $ illegalDerivStrategyErr ds case ds of - StockStrategy -> boring_case StockStrategy - AnyclassStrategy -> boring_case AnyclassStrategy - NewtypeStrategy -> boring_case NewtypeStrategy - ViaStrategy via_ty -> + StockStrategy _ -> boring_case (StockStrategy noExtField) + AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField) + NewtypeStrategy _ -> boring_case (NewtypeStrategy noExtField) + ViaStrategy (XViaStrategyPs _ via_ty) -> do checkInferredVars doc inf_err via_ty (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty let HsSig { sig_bndrs = via_outer_bndrs @@ -2079,10 +2082,11 @@ rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested -> FamilyDecl GhcPs -> RnM (FamilyDecl GhcRn, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdTopLevel = toplevel , fdFixity = fixity , fdInfo = info, fdResultSig = res_sig , fdInjectivityAnn = injectivity }) - = do { tycon' <- lookupLocatedTopBndrRn tycon + = do { tycon' <- lookupLocatedTopBndrRnN tycon ; ((tyvars', res_sig', injectivity'), fv1) <- bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ -> do { let rn_sig = rnFamResultSig doc @@ -2091,8 +2095,9 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars injectivity ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } ; (info', fv2) <- rn_info info - ; return (FamilyDecl { fdExt = noExtField + ; return (FamilyDecl { fdExt = noAnn , fdLName = tycon', fdTyVars = tyvars' + , fdTopLevel = toplevel , fdFixity = fixity , fdInfo = info', fdResultSig = res_sig' , fdInjectivityAnn = injectivity' } @@ -2133,7 +2138,7 @@ rnFamResultSig doc (TyVarSig _ tvbndr) rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLoc tvbndr) $ + addErrAt (getLocA tvbndr) $ (hsep [ text "Type variable", quotes (ppr resName) <> comma , text "naming a type family result," ] $$ @@ -2184,16 +2189,16 @@ rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -> LInjectivityAnn GhcPs -- ^ Injectivity annotation -> RnM (LInjectivityAnn GhcRn) rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) - (L srcSpan (InjectivityAnn injFrom injTo)) + (L srcSpan (InjectivityAnn x injFrom injTo)) = do - { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors) <- askNoErrs $ bindLocalNames [hsLTyVarName resTv] $ -- The return type variable scopes over the injectivity annotation -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo - ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } + ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv @@ -2205,7 +2210,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) -- not-in-scope variables) don't check the validity of injectivity -- annotation. This gives better error messages. ; when (noRnErrors && not lhsValid) $ - addErrAt (getLoc injFrom) + addErrAt (getLocA injFrom) ( vcat [ text $ "Incorrect type variable on the LHS of " ++ "injectivity condition" , nest 5 @@ -2229,12 +2234,12 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) -- -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) = setSrcSpan srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo - return $ L srcSpan (InjectivityAnn injFrom' injTo') + return $ L srcSpan (InjectivityAnn x injFrom' injTo') return $ injDecl' {- @@ -2257,14 +2262,14 @@ are no data constructors we allow h98_style = True ----------------- rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) -rnConDecls = mapFvRn (wrapLocFstM rnConDecl) +rnConDecls = mapFvRn (wrapLocFstMA rnConDecl) rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = mcxt, con_args = args , con_doc = mb_doc, con_forall = forall }) - = do { _ <- addLocM checkConName name - ; new_name <- lookupLocatedTopBndrRn name + = do { _ <- addLocMA checkConName name + ; new_name <- lookupLocatedTopBndrRnN name -- We bind no implicit binders here; this is just like -- a nested HsForAllTy. E.g. consider @@ -2285,7 +2290,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs [ text "ex_tvs:" <+> ppr ex_tvs , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) - ; return (decl { con_ext = noExtField + ; return (decl { con_ext = noAnn , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args , con_doc = mb_doc @@ -2298,8 +2303,8 @@ rnConDecl (ConDeclGADT { con_names = names , con_g_args = args , con_res_ty = res_ty , con_doc = mb_doc }) - = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names + = do { mapM_ (addLocMA checkConName) names + ; new_names <- mapM lookupLocatedTopBndrRnN names ; let -- We must ensure that we extract the free tkvs in left-to-right -- order of their appearance in the constructor type. @@ -2329,7 +2334,7 @@ rnConDecl (ConDeclGADT { con_names = names ; traceRn "rnConDecl (ConDeclGADT)" (ppr names $$ ppr outer_bndrs') - ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names + ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt , con_g_args = new_args, con_res_ty = new_res_ty , con_doc = mb_doc }, @@ -2372,8 +2377,8 @@ rnConDeclGADTDetails con doc (RecConGADT flds) rnRecConDeclFields :: Name -> HsDocContext - -> Located [LConDeclField GhcPs] - -> RnM (Located [LConDeclField GhcRn], FreeVars) + -> LocatedL [LConDeclField GhcPs] + -> RnM (LocatedL [LConDeclField GhcRn], FreeVars) rnRecConDeclFields con doc (L l fields) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields @@ -2410,13 +2415,13 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n , psb_args = RecCon as }))) <- bind = do - bnd_name <- newTopSrcBinder (L bind_loc n) - let field_occs = map ((\ f -> L (getLoc (rdrNameFieldOcc f)) f) . recordPatSynField) as + bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) + let field_occs = map ((\ f -> L (getLocA (rdrNameFieldOcc f)) f) . recordPatSynField) as flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs return ((bnd_name, flds): names) | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do - bnd_name <- newTopSrcBinder (L bind_loc n) + bnd_name <- newTopSrcBinder (L (la2na bind_loc) n) return ((bnd_name, []): names) | otherwise = return names @@ -2431,17 +2436,18 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] rnFds fds - = mapM (wrapLocM rn_fds) fds + = mapM (wrapLocMA rn_fds) fds where - rn_fds (tys1, tys2) + rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn) + rn_fds (FunDep x tys1 tys2) = do { tys1' <- rnHsTyVars tys1 ; tys2' <- rnHsTyVars tys2 - ; return (tys1', tys2') } + ; return (FunDep x tys1' tys2') } -rnHsTyVars :: [Located RdrName] -> RnM [Located Name] +rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name] rnHsTyVars tvs = mapM rnHsTyVar tvs -rnHsTyVar :: Located RdrName -> RnM (Located Name) +rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name) rnHsTyVar (L l tyvar) = do tyvar' <- lookupOccRn tyvar return (L l tyvar') @@ -2470,7 +2476,7 @@ addl gp [] = return (gp, Nothing) addl gp (L l d : ds) = add gp l d ds -add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] +add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs] -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- #10047: Declaration QuasiQuoters are expanded immediately, without @@ -2486,7 +2492,7 @@ add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds case flag of ExplicitSplice -> return () ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell - ; unless th_on $ setSrcSpan loc $ + ; unless th_on $ setSrcSpan (locA loc) $ failWith badImplicitSplice } ; return (gp, Just (splice, ds)) } diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 92e1309bd6..6c99bf7b5b 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -286,13 +286,12 @@ Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in rnImportDecl :: Module -> LImportDecl GhcPs -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod - (L loc decl@(ImportDecl { ideclExt = noExtField - , ideclName = loc_imp_mod_name + (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name , ideclPkgQual = mb_pkg , ideclSource = want_boot, ideclSafe = mod_safe , ideclQualified = qual_style, ideclImplicit = implicit , ideclAs = as_mod, ideclHiding = imp_details })) - = setSrcSpan loc $ do + = setSrcSpanA loc $ do when (isJust mb_pkg) $ do pkg_imports <- xoptM LangExt.PackageImports @@ -323,7 +322,7 @@ rnImportDecl this_mod -- or the name of this_mod's package. Yurgh! -- c.f. GHC.findModule, and #9997 Nothing -> True - Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || + Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" || fsToUnit pkg_fs == moduleUnit this_mod)) (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) @@ -362,7 +361,7 @@ rnImportDecl this_mod let qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = loc, is_as = qual_mod_name } + is_dloc = locA loc, is_as = qual_mod_name } -- filter the imports according to the import declaration (new_imp_details, gres) <- filterImports iface imp_spec imp_details @@ -385,7 +384,7 @@ rnImportDecl this_mod let home_unit = hsc_home_unit hsc_env imv = ImportedModsVal { imv_name = qual_mod_name - , imv_span = loc + , imv_span = locA loc , imv_is_safe = mod_safe' , imv_is_hiding = is_hiding , imv_all_exports = potential_gres @@ -833,17 +832,17 @@ getLocalNonValBinders fixity_env where ValBinds _ _val_binds val_sigs = binds - for_hs_bndrs :: [Located RdrName] + for_hs_bndrs :: [LocatedN RdrName] for_hs_bndrs = hsForeignDeclsBinders foreign_decls -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders - hs_boot_sig_bndrs = [ L decl_loc (unLoc n) + hs_boot_sig_bndrs = [ L (l2l decl_loc) (unLoc n) | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name - new_simple :: Located RdrName -> RnM AvailInfo + new_simple :: LocatedN RdrName -> RnM AvailInfo new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name ; return (avail nm) } @@ -851,7 +850,7 @@ getLocalNonValBinders fixity_env -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl - ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs + ; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds ; let fld_env = case unLoc tc_decl of DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' @@ -914,7 +913,7 @@ getLocalNonValBinders fixity_env -- See (1) above L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty -- See (2) above - MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr + MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe cls_rdr -- Assuming the previous step succeeded, process any associated data -- family instances. If the previous step failed, bail out. case mb_cls_nm of @@ -929,7 +928,7 @@ getLocalNonValBinders fixity_env new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) ; let (bndrs, flds) = hsDataFamInstBinders dfid - ; sub_names <- mapM newTopSrcBinder bndrs + ; sub_names <- mapM (newTopSrcBinder .l2n) bndrs ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds ; let avail = availTC (unLoc main_name) sub_names flds' -- main_name is not bound here! @@ -943,7 +942,7 @@ getLocalNonValBinders fixity_env newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) - = do { selName <- newTopSrcBinder $ L loc $ field + = do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field ; return $ FieldLabel { flLabel = fieldLabelString , flHasDuplicateRecordFields = dup_fields_ok , flHasFieldSelector = has_sel @@ -1080,8 +1079,8 @@ See T16745 for a test of this. filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, Located [LIE GhcPs]) -- Import spec; True => hiding - -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names + -> Maybe (Bool, LocatedL [LIE GhcPs]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, LocatedL [LIE GhcRn]), -- Import spec w/ Names [GlobalRdrElt]) -- Same again, but in GRE form filterImports iface decl_spec Nothing = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) @@ -1157,7 +1156,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] lookup_lie (L loc ieRdr) - = do (stuff, warns) <- setSrcSpan loc $ + = do (stuff, warns) <- setSrcSpanA loc $ liftM (fromMaybe ([],[])) $ run_lookup (lookup_ie ieRdr) mapM_ emit_warning warns @@ -1217,7 +1216,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) | otherwise -> [] - renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name)) + renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name)) sub_avails = case avail of Avail {} -> [] AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))] @@ -1245,7 +1244,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do (name, avail, mb_parent) - <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc) + <- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc) -- Look up the children in the sub-names of the parent -- See Note [Importing DuplicateRecordFields] @@ -1284,9 +1283,9 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where mkIEThingAbs tc l (n, av, Nothing ) - = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n) + = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), trimAvail av n) mkIEThingAbs tc l (n, _, Just parent) - = (IEThingAbs noExtField (L l (replaceWrappedName tc n)) + = (IEThingAbs noAnn (L l (replaceWrappedName tc n)) , availTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of @@ -1337,7 +1336,8 @@ gresFromIE decl_spec (L loc ie, avail) prov_fn name = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) where - item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } + item_spec = ImpSome { is_explicit = is_explicit name + , is_iloc = locA loc } {- @@ -1368,7 +1368,7 @@ findChildren env n = lookupNameEnv env n `orElse` [] lookupChildren :: [GreName] -> [LIEWrappedName RdrName] -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed - ([Located Name], [Located FieldLabel]) + ([LocatedA Name], [Located FieldLabel]) -- (lookupChildren all_kids rdr_items) maps each rdr_item to its -- corresponding Name all_kids, if the former exists -- The matching is done by FastString, not OccName, so that @@ -1380,19 +1380,19 @@ lookupChildren all_kids rdr_items | null fails = Succeeded (fmap concat (partitionEithers oks)) -- This 'fmap concat' trickily applies concat to the /second/ component - -- of the pair, whose type is ([Located Name], [[Located FieldLabel]]) + -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]]) | otherwise = Failed fails where mb_xs = map doOne rdr_items fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] oks = [ ok | Succeeded ok <- mb_xs ] - oks :: [Either (Located Name) [Located FieldLabel]] + oks :: [Either (LocatedA Name) [Located FieldLabel]] doOne item@(L l r) = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of Just [NormalGreName n] -> Succeeded (Left (L l n)) - Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L l) fs)) + Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L (locA l)) fs)) _ -> Failed item -- See Note [Children for duplicate record fields] @@ -1578,7 +1578,7 @@ findImportUsage imports used_gres unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) = (decl, used_gres, nameSetElemsStable unused_imps) where - used_gres = lookupSrcLoc (srcSpanEnd loc) import_usage + used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage -- srcSpanEnd: see Note [The ImportMap] `orElse` [] @@ -1677,7 +1677,7 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- Nothing used; drop entire declaration | null used - = addWarnAt (Reason flag) loc msg1 + = addWarnAt (Reason flag) (locA loc) msg1 -- Everything imported is used; nop | null unused @@ -1688,11 +1688,11 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) | Just (_, L _ imports) <- ideclHiding decl , length unused == 1 , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports - = addWarnAt (Reason flag) loc msg2 + = addWarnAt (Reason flag) (locA loc) msg2 -- Some imports are unused | otherwise - = addWarnAt (Reason flag) loc msg2 + = addWarnAt (Reason flag) (locA loc) msg2 where msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant @@ -1759,7 +1759,7 @@ getMinimalImports = fmap combine . mapM mk_minimal ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg) ; let used_avails = gresToAvailInfo used_gres lies = map (L l) (concatMap (to_ie iface) used_avails) - ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } + ; return (L l (decl { ideclHiding = Just (False, L (l2l l) lies) })) } where doc = text "Compute minimal imports for" <+> ppr decl @@ -1768,25 +1768,26 @@ getMinimalImports = fmap combine . mapM mk_minimal -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. to_ie _ (Avail c) -- Note [Overloaded field import] - = [IEVar noExtField (to_ie_post_rn $ noLoc (greNamePrintableName c))] + = [IEVar noExtField (to_ie_post_rn $ noLocA (greNamePrintableName c))] to_ie _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else - | availExportsDecl avail = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] + | availExportsDecl avail = [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)] to_ie iface (AvailTC n cs) = case [xs | avail@(AvailTC x xs) <- mi_exports iface , x == n , availExportsDecl avail -- Note [Partial export] ] of - [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)] + [xs] | all_used xs -> + [IEThingAll noAnn (to_ie_post_rn $ noLocA n)] | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns))] + [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] -- Note [Overloaded field import] _other | all_non_overloaded fs - -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns + -> map (IEVar noExtField . to_ie_post_rn_var . noLocA) $ ns ++ map flSelector fs | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLoc n) NoIEWildcard - (map (to_ie_post_rn . noLoc) (filter (/= n) ns))] + [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] where (ns, fs) = partitionGreNames cs @@ -1809,7 +1810,7 @@ getMinimalImports = fmap combine . mapM mk_minimal merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn merge [] = error "getMinimalImports: unexpected empty list" - merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L l lies) }) + merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L (noAnnSrcSpan (locA l)) lies) }) where lies = concatMap (unLoc . snd) $ mapMaybe (ideclHiding . unLoc) decls @@ -1839,16 +1840,16 @@ printMinimalImports hsc_src imports_w_usage basefn = moduleNameString (moduleName this_mod) ++ suffix -to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name +to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn_var (L l n) - | isDataOcc $ occName n = L l (IEPattern (L l n)) - | otherwise = L l (IEName (L l n)) + | isDataOcc $ occName n = L l (IEPattern (AR $ la2r l) (L (la2na l) n)) + | otherwise = L l (IEName (L (la2na l) n)) -to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name +to_ie_post_rn :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn (L l n) - | isTcOcc occ && isSymOcc occ = L l (IEType (L l n)) - | otherwise = L l (IEName (L l n)) + | isTcOcc occ && isSymOcc occ = L l (IEType (AR $ la2r l) (L (la2na l) n)) + | otherwise = L l (IEName (L (la2na l) n)) where occ = occName n {- @@ -1993,10 +1994,10 @@ dodgyMsg kind tc ie text "but it has none" ] dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) -dodgyMsgInsert tc = IEThingAll noExtField ii +dodgyMsgInsert tc = IEThingAll noAnn ii where ii :: LIEWrappedName (IdP (GhcPass p)) - ii = noLoc (IEName $ noLoc tc) + ii = noLocA (IEName $ noLocA tc) addDupDeclErr :: [GlobalRdrElt] -> TcRn () diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index f911d9b0d7..1c847dfb97 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} @@ -139,14 +140,14 @@ liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b liftCpsWithCont = CpsRn -wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) +wrapSrcSpanCps :: (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b) -- Set the location, and also wrap it around the value returned wrapSrcSpanCps fn (L loc a) - = CpsRn (\k -> setSrcSpan loc $ + = CpsRn (\k -> setSrcSpanA loc $ unCpsRn (fn a) $ \v -> k (L loc v)) -lookupConCps :: Located RdrName -> CpsRn (Located Name) +lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name) lookupConCps con_rdr = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr ; (r, fvs) <- k con_name @@ -225,12 +226,12 @@ matchNameMaker ctxt = LamMk report_unused ThPatQuote -> False _ -> True -newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) +newPatLName :: NameMaker -> LocatedN RdrName -> CpsRn (LocatedN Name) newPatLName name_maker rdr_name@(L loc _) = do { name <- newPatName name_maker rdr_name ; return (L loc name) } -newPatName :: NameMaker -> Located RdrName -> CpsRn Name +newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside -> do { name <- newLocalBndrRn rdr_name @@ -360,7 +361,7 @@ rnPat :: HsMatchContext GhcRn -- for error messages rnPat ctxt pat thing_inside = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') -applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name) +applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name) applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) ; return n } @@ -404,18 +405,18 @@ rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _ (WildPat _) = return (WildPat noExtField) rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat ; return (ParPat x pat') } -rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat - ; return (LazyPat x pat') } -rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat - ; return (BangPat x pat') } +rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat + ; return (LazyPat noExtField pat') } +rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat + ; return (BangPat noExtField pat') } rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM - ; name <- newPatName mk (L loc rdr) + ; name <- newPatName mk (L (noAnnSrcSpan loc) rdr) ; return (VarPat x (L l name)) } -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPat x pat sig) +rnPatAndThen mk (SigPat _ pat sig) -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is -- important to rename its type signature _before_ renaming the rest of the -- pattern, so that type variables are first bound by the _outermost_ pattern @@ -427,7 +428,7 @@ rnPatAndThen mk (SigPat x pat sig) -- ~~~~~~~~~~~~~~~^ the same `a' then used here = do { sig' <- rnHsPatSigTypeAndThen sig ; pat' <- rnLPatAndThen mk pat - ; return (SigPat x pat' sig' ) } + ; return (SigPat noExtField pat' sig' ) } where rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn) rnHsPatSigTypeAndThen sig = liftCpsWithCont (rnHsPatSigType AlwaysBind PatCtx sig) @@ -438,7 +439,7 @@ rnPatAndThen mk (LitPat x lit) ; if ovlStr then rnPatAndThen mk (mkNPat (noLoc (mkHsIsString src s)) - Nothing) + Nothing noAnn) else normal_lit } | otherwise = normal_lit where @@ -458,24 +459,24 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) ; eq' <- liftCpsFV $ lookupSyntax eqName ; return (NPat x (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) - = do { new_name <- newPatName mk rdr +rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ ) + = do { new_name <- newPatName mk (l2n rdr) ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as -- negative zero doesn't make -- sense in n + k patterns ; minus <- liftCpsFV $ lookupSyntax minusName ; ge <- liftCpsFV $ lookupSyntax geName - ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) - (L l lit') lit' ge minus) } + ; return (NPlusKPat noExtField (L (noAnnSrcSpan $ nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat x rdr pat) +rnPatAndThen mk (AsPat _ rdr pat) = do { new_name <- newPatLName mk rdr ; pat' <- rnLPatAndThen mk pat - ; return (AsPat x new_name pat') } + ; return (AsPat noExtField new_name pat') } -rnPatAndThen mk p@(ViewPat x expr pat) +rnPatAndThen mk p@(ViewPat _ expr pat) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns ; checkErr vp_flag (badViewPat p) } -- Because of the way we're arranging the recursive calls, @@ -484,14 +485,14 @@ rnPatAndThen mk p@(ViewPat x expr pat) ; pat' <- rnLPatAndThen mk pat -- Note: at this point the PreTcType in ty can only be a placeHolder -- ; return (ViewPat expr' pat' ty) } - ; return (ViewPat x expr' pat') } + ; return (ViewPat noExtField expr' pat') } -rnPatAndThen mk (ConPat NoExtField con args) +rnPatAndThen mk (ConPat _ con args) -- rnConPatAndThen takes care of reconstructing the pattern -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. = case unLoc con == nameRdrName (dataConName nilDataCon) of True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists - ; if ol_flag then rnPatAndThen mk (ListPat noExtField []) + ; if ol_flag then rnPatAndThen mk (ListPat noAnn []) else rnConPatAndThen mk con args} False -> rnConPatAndThen mk con args @@ -503,13 +504,13 @@ rnPatAndThen mk (ListPat _ pats) ; return (ListPat (Just to_list_name) pats')} False -> return (ListPat Nothing pats') } -rnPatAndThen mk (TuplePat x pats boxed) +rnPatAndThen mk (TuplePat _ pats boxed) = do { pats' <- rnLPatsAndThen mk pats - ; return (TuplePat x pats' boxed) } + ; return (TuplePat noExtField pats' boxed) } -rnPatAndThen mk (SumPat x pat alt arity) +rnPatAndThen mk (SumPat _ pat alt arity) = do { pat <- rnLPatAndThen mk pat - ; return (SumPat x pat alt arity) + ; return (SumPat noExtField pat alt arity) } -- If a splice has been run already, just rename the result. @@ -524,7 +525,7 @@ rnPatAndThen mk (SplicePat _ splice) -------------------- rnConPatAndThen :: NameMaker - -> Located RdrName -- the constructor + -> LocatedN RdrName -- the constructor -> HsConPatDetails GhcPs -> CpsRn (Pat GhcRn) @@ -579,7 +580,7 @@ checkUnusedRecordWildcardCps loc dotdot_names = return (r, fvs) ) -------------------- rnHsRecPatsAndThen :: NameMaker - -> Located Name -- Constructor + -> LocatedN Name -- Constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) rnHsRecPatsAndThen mk (L _ con) @@ -590,7 +591,7 @@ rnHsRecPatsAndThen mk (L _ con) ; check_unused_wildcard (implicit_binders flds' <$> dd) ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } where - mkVarPat l n = VarPat noExtField (L l n) + mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n) rn_field (L l fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' })) } @@ -631,8 +632,8 @@ rnHsRecFields HsRecFieldContext -> (SrcSpan -> RdrName -> arg) -- When punning, use this to build a new field - -> HsRecFields GhcPs (Located arg) - -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) + -> HsRecFields GhcPs (LocatedA arg) + -> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -658,8 +659,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldPat con -> Just con _ {- update -} -> Nothing - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) - -> RnM (LHsRecField GhcRn (Located arg)) + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg) + -> RnM (LHsRecField GhcRn (LocatedA arg)) rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = @@ -671,11 +672,11 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (mk_arg loc arg_rdr)) } + ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) } else return arg ; return (L l (HsRecField - { hsRecFieldLbl = (L loc (FieldOcc - sel (L ll lbl))) + { hsRecFieldAnn = noAnn + , hsRecFieldLbl = (L loc (FieldOcc sel (L ll lbl))) , hsRecFieldArg = arg' , hsRecPun = pun })) } @@ -683,8 +684,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField GhcRn (Located arg)] -- Explicit fields - -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in + -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields + -> RnM ([LHsRecField GhcRn (LocatedA arg)]) -- Field Labels we need to fill in rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add @@ -717,9 +718,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) _other -> True ] ; addUsedGREs dot_dot_gres - ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) - , hsRecFieldArg = L loc (mk_arg loc arg_rdr) + ; let locn = noAnnSrcSpan loc + ; return [ L (noAnnSrcSpan loc) (HsRecField + { hsRecFieldAnn = noAnn + , hsRecFieldLbl + = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr)) + , hsRecFieldArg = L locn (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl @@ -774,16 +778,18 @@ rnHsRecUpdFields flds then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (HsVar noExtField (L loc arg_rdr))) } + ; return (L (noAnnSrcSpan loc) (HsVar noExtField + (L (noAnnSrcSpan loc) arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' ; let (lbl', fvs') = case mb_sel of UnambiguousGre gname -> let sel_name = greNameMangledName gname - in (Unambiguous sel_name (L loc lbl), fvs `addOneFV` sel_name) - AmbiguousFields -> (Ambiguous noExtField (L loc lbl), fvs) + in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name) + AmbiguousFields -> (Ambiguous noExtField (L (noAnnSrcSpan loc) lbl), fvs) - ; return (L l (HsRecField { hsRecFieldLbl = L loc lbl' + ; return (L l (HsRecField { hsRecFieldAnn = noAnn + , hsRecFieldLbl = L loc lbl' , hsRecFieldArg = arg'' , hsRecPun = pun }), fvs') } @@ -798,9 +804,9 @@ rnHsRecUpdFields flds getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds -getFieldLbls :: [LHsRecField id arg] -> [RdrName] +getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] getFieldLbls flds - = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds + = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unXRec @p) flds getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 605da448ce..d22cabf69e 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -107,7 +107,7 @@ rnBracket e br_body ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rn_bracket cur_stage br_body - ; return (HsBracket noExtField body', fvs_e) } + ; return (HsBracket noAnn body', fvs_e) } False -> do { traceRn "Renaming untyped TH bracket" empty ; ps_var <- newMutVar [] @@ -122,7 +122,7 @@ rnBracket e br_body rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) rn_bracket outer_stage br@(VarBr x flg rdr_name) - = do { name <- lookupOccRn rdr_name + = do { name <- lookupOccRn (unLoc rdr_name) ; this_mod <- getModule ; when (flg && nameIsLocalOrFrom this_mod name) $ @@ -143,7 +143,7 @@ rn_bracket outer_stage br@(VarBr x flg rdr_name) (quotedNameStageErr br) } } } - ; return (VarBr x flg name, unitFV name) } + ; return (VarBr x flg (noLocA name), unitFV name) } rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr x e', fvs) } @@ -176,7 +176,7 @@ rn_bracket _ (DecBrL x decls) ; Just (splice, rest) -> do { group' <- groupDecls rest ; let group'' = appendGroups group group' - ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } + ; return group'' { hs_splcds = noLocA splice : hs_splcds group' } } }} @@ -377,14 +377,16 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote -mkQuasiQuoteExpr flavour quoter q_span quote - = L q_span $ HsApp noExtField (L q_span - $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector))) +mkQuasiQuoteExpr flavour quoter q_span' quote + = L q_span $ HsApp noComments (L q_span + $ HsApp noComments (L q_span + (HsVar noExtField (L (la2na q_span) quote_selector))) quoterExpr) quoteExpr where - quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter) - quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote + q_span = noAnnSrcSpan q_span' + quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter) + quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -396,19 +398,19 @@ rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc splice_name) + ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsTypedSplice x hasParen n' expr', fvs) } rnSplice (HsUntypedSplice x hasParen splice_name expr) = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc splice_name) + ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name) ; (expr', fvs) <- rnLExpr expr ; return (HsUntypedSplice x hasParen n' expr', fvs) } rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) = do { loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (L loc splice_name) + ; splice_name' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr ; quoter' <- lookupOccRn quoter @@ -428,7 +430,7 @@ rnSpliceExpr splice where pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) pend_expr_splice rn_splice - = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice) + = (makePending UntypedExpSplice rn_splice, HsSpliceE noAnn rn_splice) run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice rn_splice @@ -441,7 +443,7 @@ rnSpliceExpr splice , isLocalGRE gre] lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) } + ; return (HsSpliceE noAnn rn_splice, lcl_names `plusFV` gbl_names) } | otherwise -- Run it here, see Note [Running splices in the Renamer] = do { traceRn "rnSpliceExpr: untyped expression splice" empty @@ -449,7 +451,7 @@ rnSpliceExpr splice runRnSplice UntypedExpSplice runMetaE ppr rn_splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsPar noExtField $ HsSpliceE noExtField + ; return ( HsPar noAnn $ HsSpliceE noAnn . HsSpliced noExtField (ThModFinalizers mod_finalizers) . HsSplicedExpr <$> lexpr3 @@ -623,7 +625,7 @@ rnSpliceType splice ; checkNoErrs $ rnLHsType doc hs_ty2 } -- checkNoErrs: see Note [Renamer errors] -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsParTy noExtField + ; return ( HsParTy noAnn $ HsSpliceTy noExtField . HsSpliced noExtField (ThModFinalizers mod_finalizers) . HsSplicedTy <$> @@ -693,7 +695,7 @@ rnSplicePat splice ; (pat, mod_finalizers) <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) + ; return ( Left $ ParPat noAnn $ ((SplicePat noExtField) . HsSpliced noExtField (ThModFinalizers mod_finalizers) . HsSplicedPat) `mapLoc` pat @@ -813,7 +815,7 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) = do loc <- case mb_src of Nothing -> getSrcSpanM - Just (L loc _) -> return loc + Just (L loc _) -> return (locA loc) traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) when is_decl $ do -- Raw material for -dth-dec-file diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 2edd8a2663..5787335514 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -9,7 +9,7 @@ This module contains miscellaneous functions related to renaming. -} module GHC.Rename.Utils ( - checkDupRdrNames, checkShadowedRdrNames, + checkDupRdrNames, checkDupRdrNamesN, checkShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, dupNamesErr, checkTupSize, checkCTupSize, addFvRn, mapFvRn, mapMaybeFvRn, @@ -69,7 +69,7 @@ import qualified GHC.LanguageExtensions as LangExt ********************************************************* -} -newLocalBndrRn :: Located RdrName -> RnM Name +newLocalBndrRn :: LocatedN RdrName -> RnM Name -- Used for non-top-level binders. These should -- never be qualified. newLocalBndrRn (L loc rdr_name) @@ -78,11 +78,11 @@ newLocalBndrRn (L loc rdr_name) -- See Note [Binders in Template Haskell] in "GHC.ThToHs" | otherwise = do { unless (isUnqual rdr_name) - (addErrAt loc (badQualBndrErr rdr_name)) + (addErrAt (locA loc) (badQualBndrErr rdr_name)) ; uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } -newLocalBndrsRn :: [Located RdrName] -> RnM [Name] +newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name] newLocalBndrsRn = mapM newLocalBndrRn bindLocalNames :: [Name] -> RnM a -> RnM a @@ -107,10 +107,17 @@ extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside ------------------------------------- -checkDupRdrNames :: [Located RdrName] -> RnM () +checkDupRdrNames :: [LocatedN RdrName] -> RnM () -- Check for duplicated names in a binding group checkDupRdrNames rdr_names_w_loc - = mapM_ (dupNamesErr getLoc) dups + = mapM_ (dupNamesErr getLocA) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + +checkDupRdrNamesN :: [LocatedN RdrName] -> RnM () +-- Check for duplicated names in a binding group +checkDupRdrNamesN rdr_names_w_loc + = mapM_ (dupNamesErr getLocA) dups where (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc @@ -126,14 +133,14 @@ check_dup_names names (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names --------------------- -checkShadowedRdrNames :: [Located RdrName] -> RnM () +checkShadowedRdrNames :: [LocatedN RdrName] -> RnM () checkShadowedRdrNames loc_rdr_names = do { envs <- getRdrEnvs ; checkShadowedOccs envs get_loc_occ filtered_rdrs } where filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names -- See Note [Binders in Template Haskell] in "GHC.ThToHs" - get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) + get_loc_occ (L loc rdr) = (locA loc,rdrNameOcc rdr) checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () checkDupAndShadowedNames envs names @@ -289,13 +296,13 @@ noNestedForallsContextsErr what lty = -- types of terms, so we give a slightly more descriptive error -- message in the event that they contain visible dependent -- quantification (currently only allowed in kinds). - -> Just (l, vcat [ text "Illegal visible, dependent quantification" <+> - text "in the type of a term" - , text "(GHC does not yet support this)" ]) + -> Just (locA l, vcat [ text "Illegal visible, dependent quantification" <+> + text "in the type of a term" + , text "(GHC does not yet support this)" ]) | HsForAllInvis{} <- tele - -> Just (l, nested_foralls_contexts_err) + -> Just (locA l, nested_foralls_contexts_err) L l (HsQualTy {}) - -> Just (l, nested_foralls_contexts_err) + -> Just (locA l, nested_foralls_contexts_err) _ -> Nothing where nested_foralls_contexts_err = @@ -647,15 +654,15 @@ data HsDocContext | PatCtx | SpecInstSigCtx | DefaultDeclCtx - | ForeignDeclCtx (Located RdrName) + | ForeignDeclCtx (LocatedN RdrName) | DerivDeclCtx | RuleCtx FastString - | TyDataCtx (Located RdrName) - | TySynCtx (Located RdrName) - | TyFamilyCtx (Located RdrName) - | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [Located Name] - | ClassDeclCtx (Located RdrName) + | TyDataCtx (LocatedN RdrName) + | TySynCtx (LocatedN RdrName) + | TyFamilyCtx (LocatedN RdrName) + | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance + | ConDeclCtx [LocatedN Name] + | ClassDeclCtx (LocatedN RdrName) | ExprWithTySigCtx | TypBrCtx | HsTypeCtx diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 94a4e775ad..db43ff74ac 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -799,7 +799,7 @@ findGlobalRdrEnv hsc_env imports (err : _, _) -> Left err } where idecls :: [LImportDecl GhcPs] - idecls = [noLoc d | IIDecl d <- imports] + idecls = [noLocA d | IIDecl d <- imports] imods :: [ModuleName] imods = [m | IIModule m <- imports] @@ -1190,10 +1190,11 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do -- We will ignore the returned [Id], namely [expr_id], and not really -- create a new binding. let expr_fs = fsLit "_compileParsedExpr" - expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $ - ValBinds noExtField - (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] + loc' = locA loc + expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc' + let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $ + ValBinds NoAnnSortKey + (unitBag $ mkHsVarBind loc' (getRdrName expr_name) expr) [] pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt let (hvals_io, fix_env) = case pstmt of @@ -1221,7 +1222,7 @@ dynCompileExpr expr = do parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName) + to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce hval :: Dynamic) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 7a536fcaf7..f3d6ede42d 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -294,7 +294,7 @@ renameDeriv inst_infos bagBinds -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs) + ; let aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs) -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename -- auxiliary bindings as if they were defined locally. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. @@ -502,7 +502,7 @@ derivePred tc tys mb_lderiv_strat via_tvs deriv_pred = -- We carefully set up uses of recoverM to minimize error message -- cascades. See Note [Recovering from failures in deriving clauses]. recoverM (pure Nothing) $ - setSrcSpan (getLoc deriv_pred) $ do + setSrcSpan (getLocA deriv_pred) $ do traceTc "derivePred" $ vcat [ text "tc" <+> ppr tc , text "tys" <+> ppr tys @@ -625,7 +625,7 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec) -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays. deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) - = setSrcSpan loc $ + = setSrcSpanA loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True @@ -730,7 +730,7 @@ tcStandaloneDerivInstType ctxt , sig_bndrs = outer_bndrs , sig_body = rho } let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty - pure (tvs, InferContext (Just wc_span), cls, inst_tys) + pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys) | otherwise = do dfun_ty <- tcHsClsInstType ctxt deriv_ty let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty @@ -1171,18 +1171,18 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do DerivEnv { denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask case mb_strat of - Just StockStrategy -> do + Just (StockStrategy _) -> do (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args dit <- expectAlgTyConApp cls_tys inst_ty mk_eqn_stock dit - Just AnyclassStrategy -> mk_eqn_anyclass + Just (AnyclassStrategy _) -> mk_eqn_anyclass Just (ViaStrategy via_ty) -> do (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args mk_eqn_via cls_tys inst_ty via_ty - Just NewtypeStrategy -> do + Just (NewtypeStrategy _) -> do (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args dit <- expectAlgTyConApp cls_tys inst_ty unless (isNewTyCon (dit_rep_tc dit)) $ diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs index 324e51370c..d61b7180ef 100644 --- a/compiler/GHC/Tc/Deriv/Functor.hs +++ b/compiler/GHC/Tc/Deriv/Functor.hs @@ -158,7 +158,7 @@ gen_Functor_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag fmap_bind, emptyBag) where - fmap_name = L loc fmap_RDR + fmap_name = L (noAnnSrcSpan loc) fmap_RDR fmap_bind = mkRdrFunBind fmap_name fmap_eqns fmap_eqns = [mkSimpleMatch fmap_match_ctxt [nlWildPat] @@ -169,7 +169,7 @@ gen_Functor_binds loc tycon tycon_args = (listToBag [fmap_bind, replace_bind], emptyBag) where data_cons = getPossibleDataCons tycon tycon_args - fmap_name = L loc fmap_RDR + fmap_name = L (noAnnSrcSpan loc) fmap_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns @@ -208,7 +208,7 @@ gen_Functor_binds loc tycon tycon_args , ft_co_var = panic "contravariant in ft_fmap" } -- See Note [Deriving <$] - replace_name = L loc replace_RDR + replace_name = L (noAnnSrcSpan loc) replace_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns @@ -617,8 +617,7 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do else nlParPat bare_pat rhs <- fold con_name (zipWith (\i v -> i $ nlHsVar v) insides vars_needed) - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" -- @@ -668,8 +667,7 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) rhs <- fold con_expr exps - return $ mkMatch ctxt (extra_pats ++ [pat]) rhs - (noLoc emptyLocalBinds) + return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] @@ -794,7 +792,7 @@ gen_Foldable_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag foldMap_bind, emptyBag) where - foldMap_name = L loc foldMap_RDR + foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt [nlWildPat, nlWildPat] @@ -811,14 +809,14 @@ gen_Foldable_binds loc tycon tycon_args where data_cons = getPossibleDataCons tycon tycon_args - foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns + foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns eqns = map foldr_eqn data_cons foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs where parts = sequence $ foldDataConArgs ft_foldr con - foldMap_name = L loc foldMap_RDR + foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) @@ -841,7 +839,7 @@ gen_Foldable_binds loc tycon tycon_args go NotNull = Nothing go (NullM a) = Just (Just a) - null_name = L loc null_RDR + null_name = L (noAnnSrcSpan loc) null_RDR null_match_ctxt = mkPrefixFunRhs null_name null_bind = mkRdrFunBind null_name null_eqns null_eqns = map null_eqn data_cons @@ -851,7 +849,7 @@ gen_Foldable_binds loc tycon tycon_args case convert parts of Nothing -> return $ mkMatch null_match_ctxt [nlParPat (nlWildConPat con)] - false_Expr (noLoc emptyLocalBinds) + false_Expr emptyLocalBinds Just cp -> match_null [] con cp -- Yields 'Just' an expression if we're folding over a type that mentions @@ -1023,7 +1021,7 @@ gen_Traversable_binds loc tycon _ | Phantom <- last (tyConRoles tycon) = (unitBag traverse_bind, emptyBag) where - traverse_name = L loc traverse_RDR + traverse_name = L (noAnnSrcSpan loc) traverse_RDR traverse_bind = mkRdrFunBind traverse_name traverse_eqns traverse_eqns = [mkSimpleMatch traverse_match_ctxt @@ -1036,7 +1034,7 @@ gen_Traversable_binds loc tycon tycon_args where data_cons = getPossibleDataCons tycon tycon_args - traverse_name = L loc traverse_RDR + traverse_name = L (noAnnSrcSpan loc) traverse_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 7b97d7bf22..5f2f69bee2 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -223,7 +223,7 @@ gen_Eq_binds loc tycon tycon_args = do no_tag_match_cons = null tag_match_cons -- (LHS patterns, result) - fall_through_eqn :: [([Located (Pat (GhcPass 'Parsed))] , LHsExpr GhcPs)] + fall_through_eqn :: [([LPat (GhcPass 'Parsed)] , LHsExpr GhcPs)] fall_through_eqn | no_tag_match_cons -- All constructors have arguments = case pat_match_cons of @@ -498,7 +498,8 @@ gen_Ord_binds loc tycon tycon_args = do , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con - tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) + tag_lit + = noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K @@ -577,15 +578,15 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt -- mean more tests (dynamically) nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt where - ascribeBool e = noLoc $ ExprWithTySig noExtField e - $ mkHsWildCardBndrs $ noLoc $ mkHsImplicitSigType - $ nlHsTyVar boolTyCon_RDR + ascribeBool e = noLocA $ ExprWithTySig noAnn e + $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType + $ nlHsTyVar boolTyCon_RDR nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {}) -nlConWildPat con = noLoc $ ConPat - { pat_con_ext = noExtField - , pat_con = noLoc $ getRdrName con +nlConWildPat con = noLocA $ ConPat + { pat_con_ext = noAnn + , pat_con = noLocA $ getRdrName con , pat_args = RecCon $ HsRecFields { rec_flds = [] , rec_dotdot = Nothing } @@ -841,7 +842,7 @@ gen_Ix_binds loc tycon _ = do enum_index = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [noLoc (AsPat noExtField (noLoc c_RDR) + [noLocA (AsPat noAnn (noLocA c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr [(a_RDR, ah_RDR)] ( @@ -892,13 +893,13 @@ gen_Ix_binds loc tycon _ = do single_con_range = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - noLoc (mkHsComp ListComp stmts con_expr) + noLocA (mkHsComp ListComp stmts con_expr) where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed - mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c) + mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c) (nlHsApp (nlHsVar range_RDR) - (mkLHsVarTuple [a,b])) + (mkLHsVarTuple [a,b] noAnn)) ---------------- single_con_index @@ -920,11 +921,11 @@ gen_Ix_binds loc tycon _ = do ) plus_RDR ( genOpApp ( (nlHsApp (nlHsVar unsafeRangeSize_RDR) - (mkLHsVarTuple [l,u])) + (mkLHsVarTuple [l,u] noAnn)) ) times_RDR (mk_index rest) ) mk_one l u i - = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i] + = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u] noAnn, nlHsVar i] ------------------ single_con_inRange @@ -938,7 +939,8 @@ gen_Ix_binds loc tycon _ = do else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) where - in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c] + in_range a b c + = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c] {- ************************************************************************ @@ -1043,7 +1045,7 @@ gen_Read_binds get_fixity loc tycon _ read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] + [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLocA $ mkLastStmt (result_expr con [])])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the @@ -1058,7 +1060,7 @@ gen_Read_binds get_fixity loc tycon _ -- and Symbol s for operators mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), - result_expr con []] + result_expr con []] noAnn read_non_nullary_con data_con | is_infix = mk_parser infix_prec infix_stmts body @@ -1117,7 +1119,7 @@ gen_Read_binds get_fixity loc tycon _ ------------------------------------------------------------------------ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) - , nlHsDo (DoExpr Nothing) (ss ++ [noLoc $ mkLastStmt b])] + , nlHsDo (DoExpr Nothing) (ss ++ [noLocA $ mkLastStmt b])] con_app con as = nlHsVarApps (getRdrName con) as -- con as result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) @@ -1127,7 +1129,7 @@ gen_Read_binds get_fixity loc tycon _ ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] | otherwise = [ ident_pat s ] - bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p + bindLex pat = noLocA (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p -- See Note [Use expectP] ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo") symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>") @@ -1136,7 +1138,7 @@ gen_Read_binds get_fixity loc tycon _ data_con_str con = occNameString (getOccName con) read_arg a ty = ASSERT( not (isUnliftedType ty) ) - noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) + noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])) -- When reading field labels we might encounter -- a = 3 @@ -1144,8 +1146,8 @@ gen_Read_binds get_fixity loc tycon _ -- or (#) = 4 -- Note the parens! read_field lbl a = - [noLoc - (mkPsBindStmt + [noLocA + (mkPsBindStmt noAnn (nlVarPat a) (nlHsApp read_field @@ -1639,7 +1641,7 @@ gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], em data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con as_needed = take con_arity as_RDRs - lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body)) + lift_Expr = noLocA (HsBracket noAnn (mk_bracket br_body)) br_body = nlHsApps (Exact (dataConName data_con)) (map nlHsVar as_needed) @@ -1940,7 +1942,7 @@ gen_Newtype_binds :: SrcSpan -> Type -- the representation type -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) -- See Note [Newtype-deriving instances] -gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty +gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty = do let ats = classATs cls (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls) atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats ) @@ -1949,6 +1951,8 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty , sigs , listToBag $ map DerivFamInst atf_insts ) where + locn = noAnnSrcSpan loc' + loca = noAnnSrcSpan loc' -- For each class method, generate its derived binding and instance -- signature. Using the first example from -- Note [Newtype-deriving instances]: @@ -1979,10 +1983,10 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty -- Make sure that `forall c` is in an HsOuterExplicit so that it -- scopes over the body of `op`. See "Wrinkle: Use HsOuterExplicit" in -- Note [GND and QuantifiedConstraints]. - L loc $ ClassOpSig noExtField False [loc_meth_RDR] - $ L loc $ mkHsExplicitSigType - (map mk_hs_tvb to_tvbs) - (nlHsCoreTy to_rho) + L loca $ ClassOpSig noAnn False [loc_meth_RDR] + $ L loca $ mkHsExplicitSigType noAnn + (map mk_hs_tvb to_tvbs) + (nlHsCoreTy to_rho) ) where Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id @@ -1995,13 +1999,13 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty -- Note [GND and QuantifiedConstraints]. mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs - mk_hs_tvb (Bndr tv flag) = noLoc $ KindedTyVar noExtField - flag - (noLoc (getRdrName tv)) - (nlHsCoreTy (tyVarKind tv)) + mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn + flag + (noLocA (getRdrName tv)) + (nlHsCoreTy (tyVarKind tv)) meth_RDR = getRdrName meth_id - loc_meth_RDR = L loc meth_RDR + loc_meth_RDR = L locn meth_RDR rhs_expr = nlHsVar (getRdrName coerceId) `nlHsAppType` from_tau @@ -2018,7 +2022,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty mk_atf_inst :: TyCon -> TcM FamInst mk_atf_inst fam_tc = do - rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) + rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc)) rep_lhs_tys let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' fam_tc rep_lhs_tys rep_rhs_ty @@ -2047,12 +2051,12 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty underlying_inst_tys = changeLast inst_tys rhs_ty nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty) +nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty) where hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s nlHsCoreTy :: HsCoreTy -> LHsType GhcPs -nlHsCoreTy = noLoc . XHsType +nlHsCoreTy = noLocA . XHsType mkCoerceClassMethEqn :: Class -- the class being derived -> [TyVar] -- the tvs in the instance head (this includes @@ -2101,9 +2105,11 @@ genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpecOriginal dflags loc spec = (gen_bind spec, - L loc (TypeSig noExtField [L loc (auxBindSpecRdrName spec)] + L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)] (genAuxBindSpecSig loc spec))) where + loca = noAnnSrcSpan loc + locn = noAnnSrcSpan loc gen_bind :: AuxBindSpec -> LHsBind GhcPs gen_bind (DerivTag2Con _ tag2con_RDR) = mkFunBindSE 0 loc tag2con_RDR @@ -2152,9 +2158,11 @@ genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpecDup loc original_rdr_name dup_spec = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name), - L loc (TypeSig noExtField [L loc dup_rdr_name] + L loca (TypeSig noAnn [L locn dup_rdr_name] (genAuxBindSpecSig loc dup_spec))) where + loca = noAnnSrcSpan loc + locn = noAnnSrcSpan loc dup_rdr_name = auxBindSpecRdrName dup_spec -- | Generate the type signature of an auxiliary binding. @@ -2162,17 +2170,17 @@ genAuxBindSpecDup loc original_rdr_name dup_spec genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs genAuxBindSpecSig loc spec = case spec of DerivTag2Con tycon _ - -> mk_sig $ L loc $ + -> mk_sig $ L (noAnnSrcSpan loc) $ XHsType $ mkSpecForAllTys (tyConTyVars tycon) $ intTy `mkVisFunTyMany` mkParentType tycon DerivMaxTag _ _ - -> mk_sig (L loc (XHsType intTy)) + -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy)) DerivDataDataType _ _ _ -> mk_sig (nlHsTyVar dataType_RDR) DerivDataConstr _ _ _ -> mk_sig (nlHsTyVar constr_RDR) where - mk_sig = mkHsWildCardBndrs . L loc . mkHsImplicitSigType + mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType type SeparateBagsDerivStuff = -- DerivAuxBinds @@ -2235,17 +2243,17 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName -> [([LPat GhcPs], LHsExpr GhcPs)] -> LHsBind GhcPs mkFunBindSE arity loc fun pats_and_exprs - = mkRdrFunBindSE arity (L loc fun) matches + = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches where - matches = [mkMatch (mkPrefixFunRhs (L loc fun)) + matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) + emptyLocalBinds | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] +mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches - = L loc (mkFunBind Generated fun matches) + = L (na2la loc) (mkFunBind Generated fun matches) -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last @@ -2256,11 +2264,11 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName -> [([LPat GhcPs], LHsExpr GhcPs)] -> LHsBind GhcPs mkFunBindEC arity loc fun catch_all pats_and_exprs - = mkRdrFunBindEC arity catch_all (L loc fun) matches + = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches where - matches = [ mkMatch (mkPrefixFunRhs (L loc fun)) + matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) (map (parenthesizePat appPrec) p) e - (noLoc emptyLocalBinds) + emptyLocalBinds | (p,e) <- pats_and_exprs ] -- | Produces a function binding. When no equations are given, it generates @@ -2269,11 +2277,11 @@ mkFunBindEC arity loc fun catch_all pats_and_exprs -- the right-hand side. mkRdrFunBindEC :: Arity -> (LHsExpr GhcPs -> LHsExpr GhcPs) - -> Located RdrName + -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs -mkRdrFunBindEC arity catch_all - fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches') +mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches + = L (na2la loc) (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2288,16 +2296,16 @@ mkRdrFunBindEC arity catch_all then [mkMatch (mkPrefixFunRhs fun) (replicate (arity - 1) nlWildPat ++ [z_Pat]) (catch_all $ nlHsCase z_Expr []) - (noLoc emptyLocalBinds)] + emptyLocalBinds] else matches -- | Produces a function binding. When there are no equations, it generates -- a binding with the given arity that produces an error based on the name of -- the type of the last argument. -mkRdrFunBindSE :: Arity -> Located RdrName -> +mkRdrFunBindSE :: Arity -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs -mkRdrFunBindSE arity - fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches') +mkRdrFunBindSE arity fun@(L loc fun_rdr) matches + = L (na2la loc) (mkFunBind Generated fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" @@ -2307,7 +2315,7 @@ mkRdrFunBindSE arity matches' = if null matches then [mkMatch (mkPrefixFunRhs fun) (replicate arity nlWildPat) - (error_Expr str) (noLoc emptyLocalBinds)] + (error_Expr str) emptyLocalBinds] else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index 8b0899e38a..5eff74aaa1 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -340,9 +340,9 @@ gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs]) mkBindsRep dflags gk tycon = (binds, sigs) where - binds = unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn]) + binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn]) `unionBags` - unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn]) + unitBag (mkRdrFunBind (L loc' to01_RDR) [to_eqn]) -- See Note [Generics performance tricks] sigs = if gopt Opt_InlineGenericsAggressively dflags @@ -361,7 +361,7 @@ mkBindsRep dflags gk tycon = (binds, sigs) cons = length datacons max_fields = maximum $ map dataConSourceArity datacons - inline1 f = L loc . InlineSig noExtField (L loc f) + inline1 f = L loc'' . InlineSig noAnn (L loc' f) $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 } -- The topmost M1 (the datatype metadata) has the exact same type @@ -375,6 +375,8 @@ mkBindsRep dflags gk tycon = (binds, sigs) from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts] to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ] loc = srcLocSpan (getSrcLoc tycon) + loc' = noAnnSrcSpan loc + loc'' = noAnnSrcSpan loc datacons = tyConDataCons tycon (from01_RDR, to01_RDR) = case gk of diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index aa60f706a3..d6f0a2b474 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -269,9 +269,9 @@ data DerivSpecMechanism -- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc -derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy -derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy -derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy +derivSpecMechanismToStrategy DerivSpecStock{} = StockStrategy noExtField +derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy noExtField +derivSpecMechanismToStrategy DerivSpecAnyClass = AnyclassStrategy noExtField derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index 90a703b6b5..07f2362688 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -43,7 +43,7 @@ warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation] --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _) - = do { setSrcSpan loc $ addWarnTc NoReason $ + = do { setSrcSpanA loc $ addWarnTc NoReason $ (text "Ignoring ANN annotation" <> plural anns <> comma <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi") ; return [] } @@ -55,7 +55,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do let target = annProvenanceToTarget mod provenance -- Run that annotation and construct the full Annotation data structure - setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do + setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do -- See #10826 -- Annotations allow one to bypass Safe Haskell. dflags <- getDynFlags when (safeLanguageOn dflags) $ failWithTc safeHsErr @@ -64,7 +64,7 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell." , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] -annProvenanceToTarget :: Module -> AnnProvenance Name +annProvenanceToTarget :: Module -> AnnProvenance GhcRn -> AnnTarget Name annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index cc1411ba90..4f4f53f1cf 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -138,7 +138,7 @@ tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType tcInferSigma inst (L loc rn_expr) | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr = addExprCtxt rn_expr $ - setSrcSpan loc $ + setSrcSpanA loc $ do { do_ql <- wantQuickLook rn_fun ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args @@ -650,12 +650,12 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn -- use "In the expression: arg" ---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside - = setSrcSpan arg_loc $ + = setSrcSpanA arg_loc $ addErrCtxt (funAppCtxt fun arg arg_no) $ thing_inside addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside - = setSrcSpan arg_loc $ + = setSrcSpanA arg_loc $ addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated thing_inside diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index ad5a3474c0..7ab31322c9 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -140,7 +140,7 @@ tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty) tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc) -- The main recursive function tcCmd env (L loc cmd) res_ty - = setSrcSpan loc $ do + = setSrcSpan (locA loc) $ do { cmd' <- tc_cmd env cmd res_ty ; return (L loc cmd') } @@ -149,11 +149,11 @@ tc_cmd env (HsCmdPar x cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsCmdPar x cmd') } -tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty +tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ + setSrcSpan (locA body_loc) $ tc_cmd env body res_ty - ; return (HsCmdLet x (L l binds') (L body_loc body')) } + ; return (HsCmdLet x binds' (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do @@ -259,11 +259,11 @@ tc_cmd env do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ + ; (pats', grhss') <- setSrcSpanA mtch_loc $ tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $ tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) - ; let match' = L mtch_loc (Match { m_ext = noExtField + ; let match' = L mtch_loc (Match { m_ext = noAnn , m_ctxt = LambdaExpr, m_pats = pats' , m_grhss = grhss' }) arg_tys = map (unrestricted . hsLPatType) pats' @@ -276,10 +276,10 @@ tc_cmd env match_ctxt = (LambdaExpr :: HsMatchContext GhcRn) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt - tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty + tc_grhss (GRHSs x grhss binds) stk_ty res_ty = do { (binds', grhss') <- tcLocalBinds binds $ mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs x grhss' (L l binds')) } + ; return (GRHSs x grhss' binds') } tc_grhs stk_ty res_ty (GRHS x guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ @@ -393,7 +393,7 @@ tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside thing_inside res_ty ; return (mkTcBindStmt pat' rhs', thing) } -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names +tcArrDoStmt env ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names , recS_rec_ids = rec_names }) res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind @@ -417,13 +417,18 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; let ret_table = zip tup_ids tup_rets ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] - ; return (emptyRecStmtId { recS_stmts = stmts' + ; let + stmt :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) + stmt = emptyRecStmtId + { recS_stmts = L l stmts' + -- { recS_stmts = _ stmts' , recS_later_ids = later_ids , recS_rec_ids = rec_ids , recS_ext = unitRecStmtTc { recS_later_rets = later_rets , recS_rec_rets = rec_rets - , recS_ret_ty = res_ty} }, thing) + , recS_ret_ty = res_ty} } + ; return (stmt, thing) }} tcArrDoStmt _ _ stmt _ _ diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 0ab561a0a7..e19491e93a 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -209,8 +209,8 @@ tcCompleteSigs sigs = -- There it is also where we consider if the type of the pattern match is -- compatible with the result type constructor 'mb_tc'. doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm)) - = fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $ do - cls <- mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns + = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do + cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc } doOne _ = return Nothing @@ -225,7 +225,7 @@ tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- signatures in it. The renamer checked all this tcHsBootSigs binds sigs = do { checkTc (null binds) badBootDeclErr - ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where @@ -254,7 +254,7 @@ tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside = do { ipClass <- tcLookupClass ipClassName ; (given_ips, ip_binds') <- - mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds + mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds -- If the binding binds ?x = E, we must now -- discharge any ?x constraints in expr_lie @@ -275,7 +275,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcCheckMonoExpr expr ty ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind noExtField (Right ip_id) d)) } + ; return (ip_id, (IPBind noAnn (Right ip_id) d)) } tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" -- Coerces a `t` into a dictionary for `IP "x" t`. @@ -404,7 +404,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside -- See Note [Polymorphic recursion] in "GHC.Hs.Binds". do { traceTc "tc_group rec" (pprLHsBinds binds) ; whenIsJust mbFirstPatSyn $ \lpat_syn -> - recursivePatSynErr (getLoc lpat_syn) binds + recursivePatSynErr (locA $ getLoc lpat_syn) binds ; (binds1, thing) <- go sccs ; return ([(Recursive, binds1)], thing) } -- Rec them all together @@ -444,7 +444,7 @@ recursivePatSynErr loc binds where pprLoc loc = parens (text "defined at" <+> ppr loc) pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) - <+> pprLoc loc + <+> pprLoc (locA loc) tc_single :: forall thing. TopLevelFlag -> TcSigFun -> TcPragEnv @@ -537,7 +537,7 @@ tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list ; return result } where binder_names = collectHsBindListBinders CollNoDictBinders bind_list - loc = foldr1 combineSrcSpans (map getLoc bind_list) + loc = foldr1 combineSrcSpans (map (locA . getLoc) bind_list) -- The mbinds have been dependency analysed and -- may no longer be adjacent; so find the narrowest -- span that includes them all @@ -618,7 +618,7 @@ tcPolyCheck prag_fn , fun_matches = matches })) = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) - ; mono_name <- newNameAt (nameOccName name) nm_loc + ; mono_name <- newNameAt (nameOccName name) (locA nm_loc) ; (wrap_gen, (wrap_res, matches')) <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> @@ -632,7 +632,7 @@ tcPolyCheck prag_fn -- Why mono_id in the BinderStack? -- See Note [Relevant bindings and the binder stack] - setSrcSpan bind_loc $ + setSrcSpanA bind_loc $ tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType rho_ty) @@ -648,7 +648,7 @@ tcPolyCheck prag_fn ; poly_id <- addInlinePrags poly_id prag_sigs ; mod <- getModule - ; tick <- funBindTicks nm_loc poly_id mod prag_sigs + ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs ; let bind' = FunBind { fun_id = L nm_loc poly_id2 , fun_matches = matches' @@ -743,7 +743,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports - abs_bind = L loc $ + abs_bind = L (noAnnSrcSpan loc) $ AbsBinds { abs_ext = noExtField , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] @@ -1212,7 +1212,7 @@ tcMonoBinds is_rec sig_fn no_gen -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature - = setSrcSpan b_loc $ + = setSrcSpanA b_loc $ do { ((co_fn, matches'), rhs_ty) <- tcInfer $ \ exp_ty -> tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ @@ -1254,7 +1254,7 @@ tcMonoBinds is_rec sig_fn no_gen -- GENERAL CASE tcMonoBinds _ sig_fn no_gen binds - = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds + = do { tc_binds <- mapM (wrapLocMA (tcLhs sig_fn no_gen)) binds -- Bring the monomorphic Ids, into scope for the RHSs ; let mono_infos = getMonoBindInfo tc_binds @@ -1271,7 +1271,7 @@ tcMonoBinds _ sig_fn no_gen binds ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env] ; binds' <- tcExtendRecIds rhs_id_env $ - mapM (wrapLocM tcRhs) tc_binds + mapM (wrapLocMA tcRhs) tc_binds ; return (listToBag binds', mono_infos) } @@ -1373,7 +1373,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name -- Just g = ...f... -- Hence always typechecked with InferGen do { mono_info <- tcLhsSigId no_gen (name, sig) - ; return (TcFunBind mono_info nm_loc matches) } + ; return (TcFunBind mono_info (locA nm_loc) matches) } | otherwise -- No type signature = do { mono_ty <- newOpenFlexiTyVarTy @@ -1384,7 +1384,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name ; let mono_info = MBI { mbi_poly_name = name , mbi_sig = Nothing , mbi_mono_id = mono_id } - ; return (TcFunBind mono_info nm_loc matches) } + ; return (TcFunBind mono_info (locA nm_loc) matches) } tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) = -- See Note [Typechecking pattern bindings] @@ -1460,9 +1460,9 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id)) + ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id)) matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = L loc mono_id + ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id , fun_matches = matches' , fun_ext = co_fn , fun_tick = [] } ) } @@ -1502,7 +1502,7 @@ tcExtendIdBinderStackForRhs infos thing_inside -- NotTopLevel: it's a monomorphic binding --------------------- -getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] +getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo] getMonoBindInfo tc_binds = foldr (get_info . unLoc) [] tc_binds where @@ -1773,7 +1773,7 @@ isClosedBndrGroup type_env binds -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId p, Outputable body) - => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc +patMonoBindsCtxt :: (OutputableBndrId p) + => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs index c8106858b9..d9d7232595 100644 --- a/compiler/GHC/Tc/Gen/Default.hs +++ b/compiler/GHC/Tc/Gen/Default.hs @@ -49,7 +49,7 @@ tcDefaults [L _ (DefaultDecl _ [])] = return (Just []) -- Default declaration specifying no types tcDefaults [L locn (DefaultDecl _ mono_tys)] - = setSrcSpan locn $ + = setSrcSpan (locA locn) $ addErrCtxt defaultDeclCtxt $ do { ovl_str <- xoptM LangExt.OverloadedStrings ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules @@ -67,7 +67,7 @@ tcDefaults [L locn (DefaultDecl _ mono_tys)] ; return (Just tau_tys) } tcDefaults decls@(L locn (DefaultDecl _ _) : _) - = setSrcSpan locn $ + = setSrcSpan (locA locn) $ failWithTc (dupDefaultDeclErr decls) @@ -102,14 +102,14 @@ check_instance ty cls defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc +dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) = hang (text "Multiple default declarations") 2 (vcat (map pp dup_things)) where - pp :: Located (DefaultDecl GhcRn) -> SDoc + pp :: LDefaultDecl GhcRn -> SDoc pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr locn + = text "here was another default declaration" <+> ppr (locA locn) dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" badDefaultTy :: Type -> [Class] -> SDoc diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index ec0efc48d5..168127bd19 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -154,7 +154,7 @@ type ExportOccMap = OccEnv (GreName, IE GhcPs) -- that have the same occurrence name rnExports :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list + -> Maybe (LocatedL [LIE GhcPs]) -- Nothing => no explicit export list -> RnM TcGblEnv -- Complains if two distinct exports have same OccName @@ -188,10 +188,11 @@ rnExports explicit_mod exports -- See Note [Modules without a module header] ; let real_exports | explicit_mod = exports - | has_main = Just (noLoc [noLoc (IEVar noExtField - (noLoc (IEName $ noLoc default_main)))]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope + | has_main + = Just (noLocA [noLocA (IEVar noExtField + (noLocA (IEName $ noLocA default_main)))]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope | otherwise = Nothing -- Rename the export list @@ -216,7 +217,7 @@ rnExports explicit_mod exports , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly final_ns }) } -exports_from_avail :: Maybe (Located [LIE GhcPs]) +exports_from_avail :: Maybe (LocatedL [LIE GhcPs]) -- ^ 'Nothing' means no explicit export list -> GlobalRdrEnv -> ImportAvails @@ -262,7 +263,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod where do_litem :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) - do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) + do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie) -- Maps a parent to its in-scope children kids_env :: NameEnv [GlobalRdrElt] @@ -344,14 +345,14 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod lookup_ie (IEThingAbs _ (L l rdr)) = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noExtField (L l (replaceWrappedName rdr name)) + return (IEThingAbs noAnn (L l (replaceWrappedName rdr name)) , avail) lookup_ie ie@(IEThingAll _ n') = do (n, avail, flds) <- lookup_ie_all ie n' let name = unLoc n - return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n)) + return (IEThingAll noAnn (replaceLWrappedName n' (unLoc n)) , availTC name (name:avail) flds) @@ -380,8 +381,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do name <- lookupGlobalOccRn $ ieWrappedName rdr (non_flds, flds) <- lookupChildrenExport name sub_rdrs if isUnboundName name - then return (L l name, [], [name], []) - else return (L l name, non_flds + then return (L (locA l) name, [], [name], []) + else return (L (locA l) name, non_flds , map (ieWrappedName . unLoc) non_flds , flds) @@ -401,7 +402,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) - return (L l name, non_flds, flds) + return (L (locA l) name, non_flds, flds) ------------- lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn) @@ -517,10 +518,10 @@ lookupChildrenExport spec_parent rdr_items = case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n - ; return (Left (L l (IEName (L l ub))))} + ; return (Left (L l (IEName (L (la2na l) ub))))} FoundChild par child -> do { checkPatSynParent spec_parent par child ; return $ case child of - FieldGreName fl -> Right (L (getLoc n) fl) + FieldGreName fl -> Right (L (getLocA n) fl) NormalGreName name -> Left (replaceLWrappedName n name) } IncorrectParent p c gs -> failWithDcErr p c gs diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index a74af6e564..597b9ca9cf 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -112,13 +112,13 @@ tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty - = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } tcPolyLExprNC (L loc expr) res_ty - = setSrcSpan loc $ + = setSrcSpanA loc $ do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -138,13 +138,13 @@ tcMonoExpr, tcMonoExprNC -> TcM (LHsExpr GhcTc) tcMonoExpr (L loc expr) res_ty - = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcExpr expr res_ty ; return (L loc expr') } tcMonoExprNC (L loc expr) res_ty - = setSrcSpan loc $ + = setSrcSpanA loc $ do { expr' <- tcExpr expr res_ty ; return (L loc expr') } @@ -152,13 +152,13 @@ tcMonoExprNC (L loc expr) res_ty tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. tcInferRho (L loc expr) - = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } tcInferRhoNC (L loc expr) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { (expr', rho) <- tcInfer (tcExpr expr) ; return (L loc expr', rho) } @@ -206,7 +206,7 @@ tcExpr e@(HsOverLit _ lit) res_ty = do { mb_res <- tcShortCutLit lit res_ty -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk ; case mb_res of - Just lit' -> return (HsOverLit noExtField lit') + Just lit' -> return (HsOverLit noAnn lit') Nothing -> tcApp e res_ty } -- Typecheck an occurrence of an unbound Id @@ -249,7 +249,7 @@ tcExpr e@(HsIPVar _ x) res_ty ; ipClass <- tcLookupClass ipClassName ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) ; tcWrapResult e - (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var))) + (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var))) ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. @@ -257,9 +257,9 @@ tcExpr e@(HsIPVar _ x) res_ty unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x -tcExpr (HsLam x match) res_ty +tcExpr (HsLam _ match) res_ty = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam x match')) } + ; return (mkHsWrap wrap (HsLam noExtField match')) } where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } herald = sep [ text "The lambda expression" <+> @@ -328,7 +328,7 @@ tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys ; let expr' = ExplicitTuple x tup_args1 boxity - missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys] + missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] -- See Note [Linear fields generalization] in GHC.Tc.Gen.App act_res_ty @@ -357,10 +357,10 @@ tcExpr (ExplicitSum _ alt arity expr) res_ty ************************************************************************ -} -tcExpr (HsLet x (L l binds) expr) res_ty +tcExpr (HsLet x binds expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet x (L l binds') expr') } + ; return (HsLet x binds' expr') } tcExpr (HsCase x scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. @@ -449,9 +449,9 @@ tcExpr (HsStatic fvs expr) res_ty [p_ty] ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM - ; return $ mkHsWrapCo co $ HsApp noExtField - (L loc $ mkHsWrap wrap fromStaticPtr) - (L loc (HsStatic fvs expr')) + ; return $ mkHsWrapCo co $ HsApp noComments + (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) + (L (noAnnSrcSpan loc) (HsStatic fvs expr')) } {- @@ -941,16 +941,16 @@ arithSeqEltType (Just fl) res_ty ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } ---------------- -tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc] +tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc] tcTupArgs args tys = do MASSERT( equalLength args tys ) checkTupSize (length args) mapM go (args `zip` tys) where - go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy - ; return (L l (Missing (Scaled mult arg_ty))) } - go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty - ; return (L l (Present x expr')) } + go (Missing {}, arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy + ; return (Missing (Scaled mult arg_ty)) } + go (Present x expr, arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty + ; return (Present x expr') } --------------------------- -- See TcType.SyntaxOpType also for commentary @@ -1188,7 +1188,7 @@ getFixedTyVars upd_fld_occs univ_tvs cons -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> TcM [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Are all the fields unambiguous? = case mapM isUnambiguous rbnds of @@ -1253,7 +1253,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- where T does not have field x. pickParent :: RecSelParent -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + -> TcM (LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) pickParent p (upd, xs) = case lookup p xs of -- Phew! The parent is valid for this field. @@ -1274,13 +1274,21 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- Given a (field update, selector name) pair, look up the -- selector to give a field update with an unambiguous Id lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) + -> TcM (LHsRecField' GhcRn (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) lookupSelector (L l upd, n) = do { i <- tcLookupId n ; let L loc af = hsRecFieldLbl upd lbl = rdrNameAmbiguousFieldOcc af - ; return $ L l upd { hsRecFieldLbl - = L loc (Unambiguous i (L loc lbl)) } } + -- ; return $ L l upd { hsRecFieldLbl + -- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) } + ; return $ L l HsRecField + { hsRecFieldAnn = hsRecFieldAnn upd + , hsRecFieldLbl + = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) + , hsRecFieldArg = hsRecFieldArg upd + , hsRecPun = hsRecPun upd + } + } -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head reportAmbiguousField :: TyCon -> TcM () @@ -1293,7 +1301,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty ] where rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } - loc = getLoc (head rbnds) + loc = getLocA (head rbnds) {- Game plan for record bindings @@ -1334,13 +1342,18 @@ tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) = do { mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing - Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' - , hsRecFieldArg = rhs' }))) } + -- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' + -- , hsRecFieldArg = rhs' }))) } + Just (f', rhs') -> return (Just (L l (HsRecField + { hsRecFieldAnn = hsRecFieldAnn fld + , hsRecFieldLbl = f' + , hsRecFieldArg = rhs' + , hsRecPun = hsRecPun fld}))) } tcRecordUpd :: ConLike -> [TcType] -- Expected type for each field - -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + -> [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -> TcM [LHsRecUpdField GhcTc] tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds @@ -1348,13 +1361,13 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds fields = map flSelector $ conLikeFieldLabels con_like flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) + do_bind :: LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) -> TcM (Maybe (LHsRecUpdField GhcTc)) do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af , hsRecFieldArg = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L loc lbl)) + f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl)) ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing @@ -1363,7 +1376,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds (L l (fld { hsRecFieldLbl = L loc (Unambiguous (extFieldOcc (unLoc f')) - (L loc lbl)) + (L (noAnnSrcSpan loc) lbl)) , hsRecFieldArg = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type @@ -1463,7 +1476,7 @@ badFieldTypes prs 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) badFieldsUpd - :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] + :: [LHsRecField' GhcTc (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -- Field names that don't belong to a single datacon -> [ConLike] -- Data cons of the type which the first field name belongs to -> SDoc diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 47d6e62997..ce5b052a94 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -235,7 +235,7 @@ tcFImport :: LForeignDecl GhcRn -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty , fd_fi = imp_decl })) - = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo) $ + = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty ; let @@ -376,7 +376,7 @@ tcForeignExports' decls = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls) where combine (binds, fs, gres1) (L loc fe) = do - (b, f, gres2) <- setSrcSpan loc (tcFExport fe) + (b, f, gres2) <- setSrcSpanA loc (tcFExport fe) return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2) tcFExport :: ForeignDecl GhcRn @@ -400,7 +400,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe -- We need to give a name to the new top-level binding that -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. - id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc + id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc return ( mkVarBind id rhs , ForeignExport { fd_name = L loc id , fd_sig_ty = undefined diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 4214b4cf92..2a442b3fd9 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -267,7 +267,7 @@ splitHsApps e = go e (top_ctxt 0 e) [] -- See Note [Desugar OpApp in the typechecker] go e@(OpApp _ arg1 (L l op) arg2) _ args - = ( (op, VACall op 0 l) + = ( (op, VACall op 0 (locA l)) , mkEValArg (VACall op 1 generatedSrcSpan) arg1 : mkEValArg (VACall op 2 generatedSrcSpan) arg2 : EWrap (EExpand e) @@ -275,12 +275,12 @@ splitHsApps e = go e (top_ctxt 0 e) [] go e ctxt args = ((e,ctxt), args) - set :: SrcSpan -> AppCtxt -> AppCtxt - set l (VACall f n _) = VACall f n l + set :: SrcSpanAnnA -> AppCtxt -> AppCtxt + set l (VACall f n _) = VACall f n (locA l) set _ ctxt@(VAExpansion {}) = ctxt - dec :: SrcSpan -> AppCtxt -> AppCtxt - dec l (VACall f n _) = VACall f (n-1) l + dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt + dec l (VACall f n _) = VACall f (n-1) (locA l) dec _ ctxt@(VAExpansion {}) = ctxt rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc @@ -288,19 +288,19 @@ rebuildHsApps fun _ [] = fun rebuildHsApps fun ctxt (arg : args) = case arg of EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } - -> rebuildHsApps (HsApp noExtField lfun arg) ctxt' args + -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args EPrag ctxt' p -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args EWrap (EPar ctxt') - -> rebuildHsApps (HsPar noExtField lfun) ctxt' args + -> rebuildHsApps (HsPar noAnn lfun) ctxt' args EWrap (EExpand orig) -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args EWrap (EHsWrap wrap) -> rebuildHsApps (mkHsWrap wrap fun) ctxt args where - lfun = L (appCtxtLoc ctxt) fun + lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True @@ -555,7 +555,7 @@ tcInferRecSelId (Ambiguous _ lbl) args mb_res_ty ; return (expr, idType sel_id) } ------------------------ -tc_rec_sel_id :: Located RdrName -> Name -> TcM TcId +tc_rec_sel_id :: LocatedN RdrName -> Name -> TcM TcId -- Like tc_infer_id, but returns an Id not a HsExpr, -- so we can wrap it back up into a HsRecFld tc_rec_sel_id lbl sel_name @@ -579,7 +579,7 @@ tc_rec_sel_id lbl sel_name occ = rdrNameOcc (unLoc lbl) ------------------------ -tcInferAmbiguousRecSelId :: Located RdrName +tcInferAmbiguousRecSelId :: LocatedN RdrName -> [HsExprArg 'TcpRn] -> Maybe TcRhoType -> TcM Name -- Disgusting special case for ambiguous record selectors @@ -601,7 +601,7 @@ tcInferAmbiguousRecSelId lbl args mb_res_ty | otherwise = ambiguousSelector lbl -finish_ambiguous_selector :: Located RdrName -> Type -> TcM Name +finish_ambiguous_selector :: LocatedN RdrName -> Type -> TcM Name finish_ambiguous_selector lr@(L _ rdr) parent_type = do { fam_inst_envs <- tcGetFamInstEnvs ; case tyConOf fam_inst_envs parent_type of { @@ -631,7 +631,7 @@ finish_ambiguous_selector lr@(L _ rdr) parent_type -- This field name really is ambiguous, so add a suitable "ambiguous -- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a +ambiguousSelector :: LocatedN RdrName -> TcM a ambiguousSelector (L _ rdr) = do { addAmbiguousNameErr rdr ; failM } @@ -721,7 +721,7 @@ tcExprWithSig expr hs_ty ; (expr', poly_ty) <- tcExprSig expr sig_info ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } where - loc = getLoc (dropWildCards hs_ty) + loc = getLocA (dropWildCards hs_ty) tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) @@ -822,13 +822,13 @@ tcInferOverLit lit@(OverLit { ol_val = val ; hs_lit <- mkOverLit val ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) - ; let lit_expr = L loc $ mkHsWrapCo co $ - HsLit noExtField hs_lit + ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ + HsLit noAnn hs_lit from_expr = mkHsWrap (wrap2 <.> wrap1) $ HsVar noExtField (L loc from_id) - lit' = lit { ol_witness = HsApp noExtField (L loc from_expr) lit_expr + lit' = lit { ol_witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr , ol_ext = OverLitTc rebindable res_ty } - ; return (HsOverLit noExtField lit', res_ty) } + ; return (HsOverLit noAnn lit', res_ty) } where orig = LiteralOrigin lit mb_doc = Just (ppr from_name) @@ -852,7 +852,7 @@ tcCheckId name res_ty ; addFunResCtxt rn_fun [] actual_res_ty res_ty $ tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty } where - rn_fun = HsVar noExtField (noLoc name) + rn_fun = HsVar noExtField (noLocA name) ------------------------ tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType) @@ -877,7 +877,7 @@ tc_infer_assert assert_name = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho) + ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho) } tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType) @@ -928,7 +928,7 @@ tc_infer_id id_name = text "Illegal term-level use of the type constructor" <+> quotes (ppr (tyConName ty_con)) - return_id id = return (HsVar noExtField (noLoc id), idType id) + return_id id = return (HsVar noExtField (noLocA id), idType id) return_data_con con = do { let tvs = dataConUserTyVarBinders con @@ -1105,7 +1105,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) ; lift <- if isStringTy id_ty then do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName -- See Note [Lifting strings] - ; return (HsVar noExtField (noLoc sid)) } + ; return (HsVar noExtField (noLocA sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE @@ -1122,7 +1122,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) -- Update the pending splices ; ps <- readMutVar ps_var ; let pending_splice = PendingTcSplice id_name - (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift)) + (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) (nlHsVar id)) ; writeMutVar ps_var (pending_splice : ps) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 61b66f3919..f7ad3a2af6 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -51,7 +53,7 @@ module GHC.Tc.Gen.HsType ( kcDeclHeader, tcHsLiftedType, tcHsOpenType, tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcInferLHsTypeKind, tcInferLHsType, tcInferLHsTypeUnsaturated, + tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, tcCheckLHsType, tcHsContext, tcLHsPredType, @@ -121,7 +123,6 @@ import GHC.Data.FastString import GHC.Builtin.Names hiding ( wildCardName ) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt -import GHC.Parser.Annotation import GHC.Data.Maybe import GHC.Data.Bag( unitBag ) @@ -335,19 +336,19 @@ we promote the metavariable to level 1. This is all done in kindGeneralizeNone. -} -funsSigCtxt :: [Located Name] -> UserTypeCtxt +funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt -- Returns FunSigCtxt, with no redundant-context-reporting, -- form a list of located names funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False funsSigCtxt [] = panic "funSigCtxt" -addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> Located hs_ty -> TcM a -> TcM a +addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLoc hs_ty) $ + = setSrcSpan (getLocA hs_ty) $ addErrCtxt (pprSigCtxt ctxt hs_ty) $ thing_inside -pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> Located hs_ty -> SDoc +pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc -- (pprSigCtxt ctxt <extra> <type>) -- prints In the type signature for 'f': -- f :: <type> @@ -367,7 +368,7 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type -- already checked this, so we can simply ignore it. tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) -kcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM () +kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM () -- This is a special form of tcClassSigType that is used during the -- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type. -- Importantly, this does *not* kind-generalize. Consider @@ -387,7 +388,7 @@ kcClassSigType names tcLHsType hs_ty liftedTypeKind ; return () } -tcClassSigType :: [Located Name] -> LHsSigType GhcRn -> TcM Type +tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType names sig_ty = addSigCtxt sig_ctxt sig_ty $ @@ -446,7 +447,7 @@ tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn -- Returns also an implication for the unsolved constraints tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs , sig_body = hs_ty })) ctxt_kind - = setSrcSpan loc $ + = setSrcSpanA loc $ do { (tc_lvl, wanted, (outer_bndrs, ty)) <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $ -- See Note [Failure in local type signatures] @@ -523,7 +524,7 @@ tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Used for both types and kinds tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs , sig_body = body })) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { traceTc "tc_top_lhs_type {" (ppr sig_ty) ; (tclvl, wanted, (outer_bndrs, ty)) <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ @@ -580,9 +581,12 @@ tcDerivStrategy mb_lds where tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy StockStrategy = boring_case StockStrategy - tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy - tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy + tc_deriv_strategy (StockStrategy _) + = boring_case (StockStrategy noExtField) + tc_deriv_strategy (AnyclassStrategy _) + = boring_case (AnyclassStrategy noExtField) + tc_deriv_strategy (NewtypeStrategy _) + = boring_case (NewtypeStrategy noExtField) tc_deriv_strategy (ViaStrategy ty) = do ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty let (via_tvs, via_pred) = splitForAllTyCoVars ty' @@ -596,7 +600,7 @@ tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt -> TcM Type -- Like tcHsSigType, but for a class instance declaration tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLoc hs_inst_ty) $ + = setSrcSpan (getLocA hs_inst_ty) $ do { -- Fail eagerly if tcTopLHsType fails. We are at top level so -- these constraints will never be solved later. And failing -- eagerly avoids follow-on errors when checkValidInstance @@ -690,7 +694,7 @@ tcFamTyPats fam_tc hs_pats where fam_name = tyConName fam_tc fam_arity = tyConArity fam_tc - lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) + lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name)) {- Note [tcFamTyPats: zonking the result kind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -756,7 +760,7 @@ tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind) -- Eagerly instantiate any trailing invisible binders tcInferLHsTypeKind lhs_ty@(L loc hs_ty) = addTypeCtxt lhs_ty $ - setSrcSpan loc $ -- Cover the tcInstInvisibleTyBinders + setSrcSpanA loc $ -- Cover the tcInstInvisibleTyBinders do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty ; tcInstInvisibleTyBinders res_ty res_kind } -- See Note [Do not always instantiate eagerly in types] @@ -934,7 +938,7 @@ missing any patterns. -- level. tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) tc_infer_lhs_type mode (L span ty) - = setSrcSpan span $ + = setSrcSpanA span $ tc_infer_hs_type mode ty --------------------------- @@ -1051,7 +1055,7 @@ tcLHsType hs_ty exp_kind tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType tc_lhs_type mode (L span ty) exp_kind - = setSrcSpan span $ + = setSrcSpanA span $ tc_hs_type mode ty exp_kind tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType @@ -1159,7 +1163,7 @@ tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind [] -> (liftedTypeKind, BoxedTuple) -- In the [] case, it's not clear what the kind is, so guess * - ; tys' <- sequence [ setSrcSpan loc $ + ; tys' <- sequence [ setSrcSpanA loc $ checkExpectedKind hs_ty ty kind arg_kind | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] @@ -1279,13 +1283,13 @@ tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } {- Note [Skolem escape and forall-types] @@ -1431,7 +1435,7 @@ since the two constraints should be semantically equivalent. splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) splitHsAppTys hs_ty - | is_app hs_ty = Just (go (noLoc hs_ty) []) + | is_app hs_ty = Just (go (noLocA hs_ty) []) | otherwise = Nothing where is_app :: HsType GhcRn -> Bool @@ -1446,11 +1450,15 @@ splitHsAppTys hs_ty is_app (HsParTy _ (L _ ty)) = is_app ty is_app _ = False + go :: LHsType GhcRn + -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)] + -> (LHsType GhcRn, + [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) - go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as) + go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) go (L _ (HsOpTy _ l op@(L sp _) r)) as - = ( L sp (HsTyVar noExtField NotPromoted op) + = ( L (na2la sp) (HsTyVar noAnn NotPromoted op) , HsValArg l : HsValArg r : as ) go f as = (f, as) @@ -2962,7 +2970,7 @@ tcTKTelescope mode tele thing_inside = case tele of -- HsOuterTyVarBndrs -------------------------------------- -bindOuterTKBndrsX :: OutputableBndrFlag flag +bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> HsOuterTyVarBndrs flag GhcRn -> TcM a @@ -3034,7 +3042,7 @@ bindOuterFamEqnTKBndrs hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] --------------- -tcOuterTKBndrs :: OutputableBndrFlag flag +tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed => SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) @@ -3042,7 +3050,7 @@ tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False }) -- Do not clone the outer binders -- See Note [Cloning for type variable binder] under "must not" -tcOuterTKBndrsX :: OutputableBndrFlag flag +tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) @@ -3063,13 +3071,13 @@ tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside -- Explicit tyvar binders -------------------------------------- -tcExplicitTKBndrs :: OutputableBndrFlag flag +tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True }) -tcExplicitTKBndrsX :: OutputableBndrFlag flag +tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a @@ -3095,7 +3103,7 @@ tcExplicitTKBndrsX skol_mode bndrs thing_inside -- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied -- 'TcTyMode'. bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: (OutputableBndrFlag flag) + :: (OutputableBndrFlag flag 'Renamed) => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) @@ -3124,7 +3132,7 @@ bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside hs_bndrs thing_inside -- sm_clone=False: see Note [Cloning for type variable binders] -bindExplicitTKBndrsX :: (OutputableBndrFlag flag) +bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed) => SkolemMode -> [LHsTyVarBndr flag GhcRn] -> TcM a @@ -3873,7 +3881,7 @@ tcPartialContext _ Nothing = return ([], Nothing) tcPartialContext mode (Just (L _ hs_theta)) | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- setSrcSpan wc_loc $ + = do { wc_tv_ty <- setSrcSpanA wc_loc $ tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind ; theta <- mapM (tc_lhs_pred mode) hs_theta1 ; return (theta, Just wc_tv_ty) } diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 0a85147309..2f62d3d712 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -90,7 +91,7 @@ is used in error messages. It checks that all the equations have the same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: Located Name +tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -- Expected type of function -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) @@ -136,12 +137,12 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty parser guarantees that each equation has exactly one argument. -} -tcMatchesCase :: (Outputable (body GhcRn)) => - TcMatchCtxt body -- Case context - -> Scaled TcSigmaType -- Type of scrutinee - -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives +tcMatchesCase :: (AnnoBody body) => + TcMatchCtxt body -- Case context + -> Scaled TcSigmaType -- Type of scrutinee + -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives -> ExpRhoType -- Type of whole case expressions - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty @@ -174,6 +175,7 @@ tcGRHSsPat grhss res_ty -- desugar to incorrect code. tcGRHSs match_ctxt grhss res_ty where + match_ctxt :: TcMatchCtxt HsExpr -- AZ match_ctxt = MC { mc_what = PatBindRhs, mc_body = tcBody } @@ -185,17 +187,29 @@ tcGRHSsPat grhss res_ty data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module = MC { mc_what :: HsMatchContext GhcRn, -- What kind of thing this is - mc_body :: Located (body GhcRn) -- Type checker for a body of + mc_body :: LocatedA (body GhcRn) -- Type checker for a body of -- an alternative -> ExpRhoType - -> TcM (Located (body GhcTc)) } + -> TcM (LocatedA (body GhcTc)) } + +type AnnoBody body + = ( Outputable (body GhcRn) + , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL + , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan + , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA + , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + ) -- | Type-check a MatchGroup. -tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body +tcMatches :: (AnnoBody body ) => TcMatchCtxt body -> [Scaled ExpSigmaType] -- Expected pattern types - -> ExpRhoType -- Expected result-type of the Match. - -> MatchGroup GhcRn (Located (body GhcRn)) - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) + -> ExpRhoType -- Expected result-type of the Match. + -> MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) @@ -221,21 +235,21 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) } ------------- -tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body +tcMatch :: (AnnoBody body) => TcMatchCtxt body -> [Scaled ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. - -> LMatch GhcRn (Located (body GhcRn)) - -> TcM (LMatch GhcTc (Located (body GhcTc))) + -> LMatch GhcRn (LocatedA (body GhcRn)) + -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) tcMatch ctxt pat_tys rhs_ty match - = wrapLocM (tc_match ctxt pat_tys rhs_ty) match + = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match where tc_match ctxt pat_tys rhs_ty match@(Match { m_pats = pats, m_grhss = grhss }) = add_match_ctxt match $ do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tcGRHSs ctxt grhss rhs_ty - ; return (Match { m_ext = noExtField + ; return (Match { m_ext = noAnn , m_ctxt = mc_what ctxt, m_pats = pats' , m_grhss = grhss' }) } @@ -247,8 +261,9 @@ tcMatch ctxt pat_tys rhs_ty match _ -> addErrCtxt (pprMatchInCtxt match) thing_inside ------------- -tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType - -> TcM (GRHSs GhcTc (Located (body GhcTc))) +tcGRHSs :: AnnoBody body + => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType + -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like @@ -256,23 +271,23 @@ tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType -- We used to force it to be a monotype when there was more than one guard -- but we don't need to do that any more -tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty +tcGRHSs ctxt (GRHSs _ grhss binds) res_ty = do { (binds', ugrhss) <- tcLocalBinds binds $ mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss ; let (usages, grhss') = unzip ugrhss ; tcEmitBindingUsage $ supUEs usages - ; return (GRHSs noExtField grhss' (L l binds')) } + ; return (GRHSs noExtField grhss' binds') } ------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) - -> TcM (GRHS GhcTc (Located (body GhcTc))) +tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn)) + -> TcM (GRHS GhcTc (LocatedA (body GhcTc))) tcGRHS ctxt res_ty (GRHS _ guards rhs) = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ mc_body ctxt rhs - ; return (GRHS noExtField guards' rhs') } + ; return (GRHS noAnn guards' rhs') } where stmt_ctxt = PatGuard (mc_what ctxt) @@ -285,7 +300,7 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs) -} tcDoStmts :: HsStmtContext GhcRn - -> Located [LStmt GhcRn (LHsExpr GhcRn)] + -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty @@ -332,27 +347,27 @@ type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType type TcStmtChecker body rho_type = forall thing. HsStmtContext GhcRn - -> Stmt GhcRn (Located (body GhcRn)) + -> Stmt GhcRn (LocatedA (body GhcRn)) -> rho_type -- Result type for comprehension -> (rho_type -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt GhcTc (Located (body GhcTc)), thing) + -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing) -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn +tcStmts :: (AnnoBody body) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] + -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type - -> TcM [LStmt GhcTc (Located (body GhcTc))] + -> TcM [LStmt GhcTc (LocatedA (body GhcTc))] tcStmts ctxt stmt_chk stmts res_ty = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ const (return ()) ; return stmts' } -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn +tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -- NB: higher-rank type - -> [LStmt GhcRn (Located (body GhcRn))] + -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type -> (rho_type -> TcM thing) - -> TcM ([LStmt GhcTc (Located (body GhcTc))], thing) + -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts @@ -362,11 +377,11 @@ tcStmtsAndThen _ _ [] res_ty thing_inside ; return ([], thing) } -- LetStmts are handled uniformly, regardless of context -tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts) +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts) res_ty thing_inside = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside - ; return (L loc (LetStmt x (L l binds')) : stmts', thing) } + ; return (L loc (LetStmt x binds') : stmts', thing) } -- Don't set the error context for an ApplicativeStmt. It ought to be -- possible to do this with a popErrCtxt in the tcStmt case for @@ -382,7 +397,7 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside -- For the vanilla case, handle the location-setting part | otherwise = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ + setSrcSpanA loc $ addErrCtxt (pprStmtInCtxt ctxt stmt) $ stmt_chk ctxt stmt res_ty $ \ res_ty' -> popErrCtxt $ @@ -686,7 +701,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap --------------- Typecheck the 'fmap' function ------------- ; fmap_op' <- case form of ThenForm -> return noExpr - _ -> fmap unLoc . tcCheckPolyExpr (noLoc fmap_op) $ + _ -> fmap unLoc . tcCheckPolyExpr (noLocA fmap_op) $ mkInfForAllTy alphaTyVar $ mkInfForAllTy betaTyVar $ (alphaTy `mkVisFunTyMany` betaTy) @@ -758,7 +773,7 @@ tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside (m_ty `mkAppTy` betaTy) `mkVisFunTyMany` (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) - ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLoc mzip_op) mzip_ty + ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty -- type dummies since we don't know all binder types yet ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) @@ -872,7 +887,7 @@ tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside ; return (rhs', rhs_ty, thing) } ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } -tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names +tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) res_ty thing_inside @@ -914,7 +929,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; later_ids <- tcLookupLocalIds later_names ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids), ppr later_ids <+> ppr (map idType later_ids)] - ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids + ; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' , recS_ext = RecStmtTc @@ -1036,7 +1051,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside , arg_expr = rhs , .. }, pat_ty, exp_ty) - = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $ + = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $ addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $ do { rhs' <- tcCheckMonoExprNC rhs exp_ty ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ @@ -1103,7 +1118,8 @@ the variables they bind into scope, and typecheck the thing_inside. number of args are used in each equation. -} -checkArgs :: Name -> MatchGroup GhcRn body -> TcM () +checkArgs :: AnnoBody body + => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () checkArgs _ (MG { mg_alts = L _ [] }) = return () checkArgs fun (MG { mg_alts = L _ (match1:matches) }) @@ -1112,11 +1128,11 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) }) | otherwise = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+> text "have different numbers of arguments" - , nest 2 (ppr (getLoc match1)) - , nest 2 (ppr (getLoc (head bad_matches)))]) + , nest 2 (ppr (getLocA match1)) + , nest 2 (ppr (getLocA (head bad_matches)))]) where n_args1 = args_in_match match1 bad_matches = [m | m <- matches, args_in_match m /= n_args1] - args_in_match :: LMatch GhcRn body -> Int + args_in_match :: (LocatedA (Match GhcRn body1) -> Int) args_in_match (L _ (Match { m_pats = pats })) = length pats diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot index bb194a3cf1..9f6b6bf239 100644 --- a/compiler/GHC/Tc/Gen/Match.hs-boot +++ b/compiler/GHC/Tc/Gen/Match.hs-boot @@ -4,14 +4,14 @@ import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Types.Name ( Name ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) import GHC.Tc.Types ( TcM ) -import GHC.Types.SrcLoc ( Located ) import GHC.Hs.Extension ( GhcRn, GhcTc ) +import GHC.Parser.Annotation ( LocatedN ) tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: Located Name +tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpSigmaType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 837fb7fbdc..671955feb7 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -331,7 +331,7 @@ tcMultiple tc_pat penv args thing_inside tc_lpat :: Scaled ExpSigmaType -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside - = setSrcSpan span $ + = setSrcSpanA span $ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat) thing_inside ; return (L span pat', res) } @@ -400,7 +400,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of AsPat x (L nm_loc name) pat -> do { mult_wrap <- checkManyPattern pat_ty -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. - ; (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) + ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) penv pat thing_inside @@ -532,8 +532,8 @@ Fortunately that's what matchExpectedFunTySigma returns anyway. -- pat_ty /= pat_ty iff coi /= IdCo possibly_mangled_result | gopt Opt_IrrefutableTuples dflags && - isBoxed boxity = LazyPat noExtField (noLoc unmangled_result) - | otherwise = unmangled_result + isBoxed boxity = LazyPat noExtField (noLocA unmangled_result) + | otherwise = unmangled_result ; pat_ty <- readExpType (scaledThing pat_ty) ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced @@ -653,7 +653,7 @@ AST is used for the subtraction operation. <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $ \ [lit2_ty, var_ty] _ -> do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty) - ; (wrap, bndr_id) <- setSrcSpan nm_loc $ + ; (wrap, bndr_id) <- setSrcSpanA nm_loc $ tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty) -- co :: var_ty ~ idType bndr_id @@ -854,7 +854,7 @@ same name, leading to shadowing. -- MkT :: forall a b c. (a~[b]) => b -> c -> T a -- with scrutinee of type (T ty) -tcConPat :: PatEnv -> Located Name +tcConPat :: PatEnv -> LocatedN Name -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) @@ -867,7 +867,7 @@ tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside pat_ty arg_pats thing_inside } -tcDataConPat :: PatEnv -> Located Name -> DataCon +tcDataConPat :: PatEnv -> LocatedN Name -> DataCon -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) @@ -886,7 +886,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled ; pat_ty <- readExpType (scaledThing pat_ty_scaled) -- Add the stupid theta - ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys + ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) ; checkExistentials ex_tvs all_arg_tys penv @@ -971,7 +971,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled ; return (mkHsWrapPat wrap res_pat pat_ty, res) } } -tcPatSynPat :: PatEnv -> Located Name -> PatSyn +tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) @@ -1246,14 +1246,14 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn)) (LHsRecField GhcTc (LPat GhcTc)) tc_field penv - (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun)) + (L l (HsRecField ann (L loc (FieldOcc sel (L lr rdr))) pat pun)) thing_inside = do { sel' <- tcLookupId sel ; pat_ty <- setSrcSpan loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside - ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat' - pun), res) } + ; return (L l (HsRecField ann (L loc (FieldOcc sel' (L lr rdr))) pat' + pun), res) } find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index bbbd528830..73dedfbaf5 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -99,12 +99,12 @@ equation. -} tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc] -tcRules decls = mapM (wrapLocM tcRuleDecls) decls +tcRules decls = mapM (wrapLocMA tcRuleDecls) decls tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) tcRuleDecls (HsRules { rds_src = src , rds_rules = decls }) - = do { tc_decls <- mapM (wrapLocM tcRule) decls + = do { tc_decls <- mapM (wrapLocMA tcRule) decls ; return $ HsRules { rds_ext = noExtField , rds_src = src , rds_rules = tc_decls } } @@ -175,7 +175,7 @@ tcRule (HsRule { rd_ext = ext , rd_name = rname , rd_act = act , rd_tyvs = ty_bndrs -- preserved for ppr-ing - , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc) + , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA) (qtkvs ++ tpl_ids) , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 45dbc96d8f..1d81b3636b 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -187,13 +187,13 @@ tcTySig (L _ (IdSig _ id)) ; return [TcIdSig sig] } tcTySig (L loc (TypeSig _ names sig_ty)) - = setSrcSpan loc $ - do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) + = setSrcSpanA loc $ + do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) | L _ name <- names ] ; return (map TcIdSig sigs) } tcTySig (L loc (PatSynSig _ names sig_ty)) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { tpsigs <- sequence [ tcPatSynSig name sig_ty | L _ name <- names ] ; return (map TcPatSynSig tpsigs) } @@ -288,7 +288,7 @@ no_anon_wc_ty lty = go lty && go ty HsQualTy { hst_ctxt = ctxt , hst_body = ty } -> gos (fromMaybeContext ctxt) && go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty HsSpliceTy{} -> True HsTyLit{} -> True HsTyVar{} -> True @@ -595,7 +595,7 @@ addInlinePrags poly_id prags_for_me -- and inl2 is a user NOINLINE pragma; we don't want to complain warn_multiple_inlines inl2 inls | otherwise - = setSrcSpan loc $ + = setSrcSpanA loc $ addWarnTc NoReason (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) 2 (vcat (text "Ignoring all but the first" @@ -721,8 +721,8 @@ tcSpecPrags :: Id -> [LSig GhcRn] tcSpecPrags poly_id prag_sigs = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) ; unless (null bad_sigs) warn_discarded_sigs - ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } + ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } where spec_sigs = filter isSpecLSig prag_sigs bad_sigs = filter is_bad_sig prag_sigs @@ -789,11 +789,11 @@ tcImpPrags prags ; if (not_specialising dflags) then return [] else do - { pss <- mapAndRecoverM (wrapLocM tcImpSpec) + { pss <- mapAndRecoverM (wrapLocMA tcImpSpec) [L loc (name,prag) | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags , not (nameIsLocalOrFrom this_mod name) ] - ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } } where -- Ignore SPECIALISE pragmas for imported things -- when we aren't specialising, or when we aren't generating diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 89ba997d8a..456578f729 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -215,7 +215,7 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty rn_expr (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) (nlHsTyApp texpco [rep, expr_ty])) - (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps')))) + (noLocA (HsTcBracketOut noExtField (Just wrapper) brack ps')))) meta_ty res_ty } tcTypedBracket _ other_brack _ = pprPanic "tcTypedBracket" (ppr other_brack) @@ -598,7 +598,7 @@ That effort is tracked in #14838. tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty = addErrCtxt (spliceCtxtDoc splice) $ - setSrcSpan (getLoc expr) $ do + setSrcSpan (getLocA expr) $ do { stage <- getStage ; case stage of Splice {} -> tcTopSplice expr res_ty @@ -645,7 +645,7 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) spl -- But we still return a plausible expression -- (a) in case we print it in debug messages, and -- (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp - ; return (HsSpliceE noExtField $ + ; return (HsSpliceE noAnn $ HsSpliced noExtField (ThModFinalizers []) $ HsSplicedExpr (unLoc expr'')) } @@ -666,7 +666,7 @@ tcTopSplice expr res_ty ; lcl_env <- getLclEnv ; let delayed_splice = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice))) + ; return (HsSpliceE noAnn (XSplice (HsSplicedT delayed_splice))) } @@ -776,10 +776,11 @@ runAnnotation target expr = do -- LIE consulted by tcTopSpliceExpr -- and hence ensures the appropriate dictionary is bound by const_binds ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + ; let loc' = noAnnSrcSpan loc ; let specialised_to_annotation_wrapper_expr - = L loc (mkHsWrap wrapper - (HsVar noExtField (L loc to_annotation_wrapper_id))) - ; return (L loc (HsApp noExtField + = L loc' (mkHsWrap wrapper + (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id))) + ; return (L loc' (HsApp noComments specialised_to_annotation_wrapper_expr expr')) }) @@ -961,7 +962,7 @@ runMeta' show_code ppr_hs run_and_convert expr -- encounter them inside the try -- -- See Note [Exceptions in TH] - let expr_span = getLoc expr + let expr_span = getLocA expr ; either_tval <- tryAllM $ setSrcSpan expr_span $ -- Set the span so that qLocation can -- see where this splice is diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 81cf5ea408..09edfcb8c3 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -236,7 +236,7 @@ tcRnModuleTcRnM :: HscEnv tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (L loc (HsModule _ maybe_mod export_ies + (L loc (HsModule _ _ maybe_mod export_ies import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -273,9 +273,9 @@ tcRnModuleTcRnM hsc_env mod_sum $ implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) - ; let { mkImport (Nothing, L _ mod_name) = noLoc + ; let { mkImport (Nothing, L _ mod_name) = noLocA $ (simpleImportDecl mod_name) - { ideclHiding = Just (False, noLoc [])} + { ideclHiding = Just (False, noLocA [])} ; mkImport _ = panic "mkImport" } ; let { all_imports = prel_imports ++ import_decls ++ map mkImport (raw_sig_imports ++ raw_req_imports) } @@ -437,7 +437,7 @@ tcRnImports hsc_env import_decls -} tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) + -> Maybe (LocatedL [LIE GhcPs]) -> [LHsDecl GhcPs] -- Declarations -> TcM TcGblEnv tcRnSrcDecls explicit_mod_hdr export_ies decls @@ -607,7 +607,7 @@ tc_rn_src_decls ds ; case th_group_tail of { Nothing -> return () ; Just (SpliceDecl _ (L loc _) _, _) -> - setSrcSpan loc + setSrcSpanA loc $ addErr (text ("Declaration splices are not " ++ "permitted inside top-level " @@ -728,9 +728,9 @@ tcRnHsBootDecls hsc_src decls }}} ; traceTc "boot" (ppr lie); return gbl_env } -badBootDecl :: HscSource -> String -> Located decl -> TcM () +badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _) - = addErrAt loc (char 'A' <+> text what + = addErrAt (locA loc) (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of HsBootFile -> text "hs-boot" @@ -1791,7 +1791,7 @@ checkMainType tcg_env ; return lie } } } } checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (Located [LIE GhcPs]) -- Export specs of Main module + -> Maybe (LocatedL [LIE GhcPs]) -- Export specs of Main module -> TcM TcGblEnv -- If we are in module Main, check that 'main' is exported, -- and generate the runMainIO binding that calls it @@ -1872,7 +1872,7 @@ generateMainBinding tcg_env main_name = do { traceTc "checkMain found" (ppr main_name) ; (io_ty, res_ty) <- getIOType ; let loc = getSrcSpan main_name - main_expr_rn = L loc (HsVar noExtField (L loc main_name)) + main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name)) ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ tcCheckMonoExpr main_expr_rn io_ty @@ -2228,20 +2228,21 @@ tcUserStmt (L loc (BodyStmt _ expr _ _)) -- Don't try to typecheck if the renamer fails! ; ghciStep <- getGhciStepIO ; uniq <- newUnique + ; let loc' = noAnnSrcSpan $ locA loc ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq loc - matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr - (noLoc emptyLocalBinds)] + ; let fresh_it = itName uniq (locA loc) + matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr + emptyLocalBinds] -- [it = expr] the_bind = L loc $ (mkTopFunBind FromSource - (L loc fresh_it) matches) + (L loc' fresh_it) matches) { fun_ext = fvs } -- Care here! In GHCi the expression might have -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField + let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) @@ -2251,7 +2252,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _)) { xbsrn_bindOp = mkRnSyntaxExpr bindIOName , xbsrn_failOp = Nothing }) - (L loc (VarPat noExtField (L loc fresh_it))) + (L loc (VarPat noExtField (L loc' fresh_it))) (nlHsApp ghciStep rn_expr) -- [; print it] @@ -2373,7 +2374,7 @@ But for naked expressions, you will have tcUserStmt rdr_stmt@(L loc _) = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do + rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do fix_env <- getFixityEnv return (fix_env, emptyFVs) -- Don't try to typecheck if the renamer fails! @@ -2475,17 +2476,17 @@ tcGhciStmts stmts -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ - noLoc $ ExplicitList unitTy $ + noLocA $ ExplicitList unitTy $ map mk_item ids mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) , getRuntimeRep unitTy , idType id, unitTy] `nlHsApp` nlHsVar id - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)] ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts))) + noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts))) } -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) @@ -2497,7 +2498,7 @@ getGhciStepIO = do ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) step_ty :: LHsSigType GhcRn - step_ty = noLoc $ HsSig + step_ty = noLocA $ HsSig { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]} , sig_ext = noExtField , sig_body = nlHsFunTy ghciM ioM } @@ -2505,7 +2506,7 @@ getGhciStepIO = do stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs step_ty - return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) + return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name) isGHCiMonad hsc_env ty @@ -2550,7 +2551,7 @@ tcRnExpr hsc_env mode rdr_expr -- Generalise uniq <- newUnique ; - let { fresh_it = itName uniq (getLoc rdr_expr) } ; + let { fresh_it = itName uniq (getLocA rdr_expr) } ; ((qtvs, dicts, _, _), residual) <- captureConstraints $ simplifyInfer tclvl infer_mode @@ -2783,12 +2784,12 @@ getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod -tcRnLookupRdrName :: HscEnv -> Located RdrName +tcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (Messages DecoratedSDoc, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ - setSrcSpan loc $ + setSrcSpanA loc $ do { -- If the identifier is a constructor (begins with an -- upper-case letter), then we need to consider both -- constructor and type class identifiers. @@ -2928,7 +2929,7 @@ tcDump env full_dump = pprLHsBinds (tcg_binds env) -- NB: foreign x-d's have undefined's in their types; -- hence can't show the tc_fords - ast_dump = showAstData NoBlankSrcSpan (tcg_binds env) + ast_dump = showAstData NoBlankSrcSpan NoBlankApiAnnotations (tcg_binds env) -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index ec8c2bb66e..bcb9fa084d 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -1286,7 +1286,7 @@ inferInitialKinds decls ; traceTc "inferInitialKinds done }" empty ; return tcs } where - infer_initial_kind = addLocM (getInitialKind InitialKindInfer) + infer_initial_kind = addLocMA (getInitialKind InitialKindInfer) -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each. @@ -1298,7 +1298,7 @@ checkInitialKinds decls ; return tcs } where check_initial_kind (ldecl, msig) = - addLocM (getInitialKind (InitialKindCheck msig)) ldecl + addLocMA (getInitialKind (InitialKindCheck msig)) ldecl -- | Get the initial kind of a TyClDecl, either generalized or non-generalized, -- depending on the 'InitialKindStrategy'. @@ -1327,7 +1327,7 @@ getInitialKind strategy -- See Note [Don't process associated types in getInitialKind] ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocM (getAssocFamInitialKind cls)) ats + mapM (addLocMA (getAssocFamInitialKind cls)) ats ; return (cls : inner_tcs) } where getAssocFamInitialKind cls = @@ -1531,7 +1531,7 @@ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls] -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { tycon <- tcLookupTcTyCon tc_name ; traceTc "kcTyClDecl {" (ppr tc_name) ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] @@ -1569,7 +1569,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon = bindTyClTyVars name $ \ _ _ _ -> do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM_ kc_sig) sigs } + ; mapM_ (wrapLocMA_ kc_sig) sigs } where kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty kc_sig _ = return () @@ -1617,7 +1617,7 @@ kcConDecls :: NewOrData -> TcM () -- See Note [kcConDecls: kind-checking data type decls] kcConDecls new_or_data tc_res_kind cons - = mapM_ (wrapLocM_ (kcConDecl new_or_data tc_res_kind)) cons + = mapM_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons -- Kind check a data constructor. In additional to the data constructor, -- we also need to know about whether or not its corresponding type was @@ -2323,7 +2323,7 @@ tcTyClDecl roles_info (L loc decl) _ -> pprPanic "tcTyClDecl" (ppr thing) | otherwise - = setSrcSpan loc $ tcAddDeclCtxt decl $ + = setSrcSpanA loc $ tcAddDeclCtxt decl $ do { traceTc "---- tcTyClDecl ---- {" (ppr decl) ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) @@ -2341,7 +2341,7 @@ wiredInDerivInfo tycon decl if isFunTyCon tycon || isPrimTyCon tycon then [] -- no tyConTyVars else mkTyVarNamePairs (tyConTyVars tycon) - , di_clauses = unLoc derivs + , di_clauses = derivs , di_ctxt = tcMkDeclCtxt decl } ] wiredInDerivInfo _ _ = [] @@ -2404,7 +2404,7 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs -- The (binderVars binders) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocM tc_fundep) fundeps + ; fds <- mapM (addLocMA tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths ; at_stuff <- tcClassATs class_name clas ats at_defs ; return (ctxt, fds, sig_stuff, at_stuff) } @@ -2448,9 +2448,11 @@ tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs ; return clas } where skol_info = TyConSkol ClassFlavour class_name - tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; + tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var]) + tc_fundep (FunDep _ tvs1 tvs2) + = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; - ; return (tvs1', tvs2') } + ; return (tvs1',tvs2') } {- Note [Associated type defaults] @@ -2493,7 +2495,7 @@ tcClassATs class_name cls ats at_defs (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs - tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at + tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) `orElse` [] ; atd <- tcDefaultAssocDecl fam_tc at_defs @@ -2518,7 +2520,7 @@ tcDefaultAssocDecl fam_tc , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty }})] = -- See Note [Type-checking default assoc decls] - setSrcSpan loc $ + setSrcSpanA loc $ tcAddFamInstCtxt (text "default type instance") tc_name $ do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) ; let fam_tc_name = tyConName fam_tc @@ -2559,7 +2561,7 @@ tcDefaultAssocDecl fam_tc -- simply create an empty substitution and let GHC fall -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt. -- See Note [Type-checking default assoc decls]. - ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI loc pats) + ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI (locA loc) pats) -- We perform checks for well-formedness and validity later, in -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. } @@ -2789,7 +2791,7 @@ tcInjectivity _ Nothing -- therefore we can always infer the result kind if we know the result type. -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags @@ -2903,7 +2905,7 @@ tcDataDefn err_ctxt roles_info tc_name gadt_syntax) } ; let deriv_info = DerivInfo { di_rep_tc = tycon , di_scoped_tvs = tcTyConScopedTyVars tctc - , di_clauses = unLoc derivs + , di_clauses = derivs , di_ctxt = err_ctxt } ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) ; return (tycon, [deriv_info]) } @@ -2946,7 +2948,7 @@ kcTyFamInstEqn tc_fam_tc , feqn_bndrs = outer_bndrs , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty })) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { traceTc "kcTyFamInstEqn" (vcat [ text "tc_name =" <+> ppr eqn_tc_name , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) @@ -2989,7 +2991,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo (L loc (FamEqn { feqn_bndrs = outer_bndrs , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty })) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { traceTc "tcTyFamInstEqn" $ vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) @@ -3012,7 +3014,7 @@ tcTyFamInstEqn fam_tc mb_clsinfo -- (tcFamInstEqnGuts zonks to Type) ; return (mkCoAxBranch qtvs [] [] pats rhs_ty (map (const Nominal) qtvs) - loc) } + (locA loc)) } {- Note [Instantiating a family tycon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3150,7 +3152,7 @@ checkFamTelescope tclvl hs_outer_bndrs outer_tvs , (b_first : _) <- bndrs , let b_last = last bndrs skol_info = ForAllSkol (fsep (map ppr bndrs)) - = setSrcSpan (combineSrcSpans (getLoc b_first) (getLoc b_last)) $ + = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC | otherwise = return () @@ -3324,7 +3326,7 @@ tcConDecls :: NewOrData -> TcKind -- Result kind -> [LConDecl GhcRn] -> TcM [DataCon] tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind - = concatMapM $ addLocM $ + = concatMapM $ addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) -- mkTyConTagMap: it's important that we pay for tag allocation here, @@ -3664,7 +3666,7 @@ tcConArg exp_kind (HsScaled w bty) ; return (Scaled w' arg_ty, getBangStrictness bty) } tcRecConDeclFields :: ContextKind - -> Located [LConDeclField GhcRn] + -> LocatedL [LConDeclField GhcRn] -> TcM [(Scaled TcType, HsSrcBang)] tcRecConDeclFields exp_kind fields = mapM (tcConArg exp_kind) btys @@ -4292,7 +4294,7 @@ checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan con_loc $ - addErrCtxt (dataConCtxt [L con_loc con_name]) $ + addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $ do { let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) orig_res_ty = dataConOrigResTy con @@ -4891,7 +4893,7 @@ checkValidRoleAnnots role_annots tc = whenIsJust role_annot_decl_maybe $ \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ - setSrcSpan loc $ do + setSrcSpanA loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations ; checkTc role_annots_ok $ needXRoleAnnotations tc ; checkTc (vis_vars `equalLength` the_role_annots) @@ -5087,15 +5089,15 @@ fieldTypeMisMatch field_name con1 con2 = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] -dataConCtxt :: [Located Name] -> SDoc +dataConCtxt :: [LocatedN Name] -> SDoc dataConCtxt cons = text "In the definition of data constructor" <> plural cons <+> ppr_cons cons -dataConResCtxt :: [Located Name] -> SDoc +dataConResCtxt :: [LocatedN Name] -> SDoc dataConResCtxt cons = text "In the result type of data constructor" <> plural cons <+> ppr_cons cons -ppr_cons :: [Located Name] -> SDoc +ppr_cons :: [LocatedN Name] -> SDoc ppr_cons [con] = quotes (ppr con) ppr_cons cons = interpp'SP cons @@ -5217,7 +5219,7 @@ wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ - setSrcSpan loc $ + setSrcSpanA loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.") diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 8e637a1a32..80804ecaea 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -152,12 +152,14 @@ tcClassSigs clas sigs def_methods ; traceTc "tcClassSigs 2" (ppr clas) ; return op_info } where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] + vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp + vanilla_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] + gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp + gen_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] - tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn) + tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn) -> TcM [TcMethInfo] tc_sig gen_dm_env (op_names, op_hs_ty) = do { traceTc "ClsSig 1" (ppr op_names) @@ -171,9 +173,12 @@ tcClassSigs clas sigs def_methods | nm `elem` dm_bind_names = Just VanillaDM | otherwise = Nothing + tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn) + -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp tc_gen_sig (op_names, gen_hs_ty) = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty - ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] } + ; return [ (op_name, (locA loc, gen_op_ty)) + | L loc op_name <- op_names ] } {- ************************************************************************ @@ -188,9 +193,9 @@ tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) - = recoverM (return emptyLHsBinds) $ - setSrcSpan (getLoc class_name) $ - do { clas <- tcLookupLocatedClass class_name + = recoverM (return emptyLHsBinds) $ + setSrcSpan (getLocA class_name) $ + do { clas <- tcLookupLocatedClass (n2l class_name) -- We make a separate binding for each default method. -- At one time I used a single AbsBinds for all of them, thus @@ -227,7 +232,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) = do { -- No default method - mapM_ (addLocM (badDmPrag sel_id)) + mapM_ (addLocMA (badDmPrag sel_id)) (lookupPragEnv prag_fn (idName sel_id)) ; return emptyBag } @@ -272,7 +277,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) - lm_bind = dm_bind { fun_id = L bind_loc local_dm_name } + lm_bind = dm_bind { fun_id = L (la2na bind_loc) local_dm_name } -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind @@ -288,7 +293,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty local_dm_sig = CompleteSig { sig_bndr = local_dm_id , sig_ctxt = ctxt - , sig_loc = getLoc hs_ty } + , sig_loc = getLocA hs_ty } ; (ev_binds, (tc_bind, _)) <- checkConstraints skol_info tyvars [this_dict] $ @@ -337,7 +342,7 @@ tcClassMinimalDef _clas sigs op_info where -- By default require all methods without a default implementation defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLoc (mkVar name) + defMindef = mkAnd [ noLocA (mkVar name) | (name, _, Nothing) <- op_info ] instantiateMethod :: Class -> TcId -> [TcType] -> TcType @@ -368,7 +373,7 @@ mkHsSigFun sigs = lookupNameEnv env where env = mkHsSigEnv get_classop_sig sigs - get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) + get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn) get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) get_classop_sig _ = Nothing @@ -387,7 +392,7 @@ findMethodBind sel_name binds prag_fn f bind@(L _ (FunBind { fun_id = L bndr_loc op_name })) | op_name == sel_name - = Just (bind, bndr_loc, prags) + = Just (bind, locA bndr_loc, prags) f _other = Nothing --------------------------- @@ -517,7 +522,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) (tv', cv') = partition isTyVar tcv' tvs' = scopedSort tv' cvs' = scopedSort cv' - ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys' + ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys' ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs' fam_tc pat_tys' rhs' -- NB: no validity check. We check validity of default instances diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 8bfb5370bb..ec05dffaae 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -484,7 +484,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = overlap_mode , cid_datafam_insts = adts })) - = setSrcSpan loc $ + = setSrcSpanA loc $ addErrCtxt (instDeclCtxt1 hs_ty) $ do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty @@ -517,7 +517,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds -- from their defaults (if available) ; is_boot <- tcIsHsBootOrSig ; let atItems = classATItems clas - ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats) + ; tf_insts2 <- mapM (tcATDefault (locA loc) mini_subst defined_ats) (if is_boot then [] else atItems) -- Don't default type family instances, but rather omit, in hsig/hs-boot. -- Since hsig/hs-boot files are essentially large binders we want omission @@ -532,7 +532,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (getLoc hs_ty) + ; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty) -- Dfun location is that of instance *header* ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name @@ -581,7 +581,7 @@ tcTyFamInstDecl :: AssocInstInfo -- "type instance" -- See Note [Associated type instances] tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) - = setSrcSpan loc $ + = setSrcSpanA loc $ tcAddTyFamInstCtxt decl $ do { let fam_lname = feqn_tycon eqn ; fam_tc <- tcLookupLocatedTyCon fam_lname @@ -595,7 +595,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) -- For some reason we don't have a location for the equation -- itself, so we make do with the location of family name ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo - (L (getLoc fam_lname) eqn) + (L (na2la $ getLoc fam_lname) eqn) -- (2) check for validity ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch @@ -677,7 +677,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env , dd_cons = hs_cons , dd_kindSig = m_ksig , dd_derivs = derivs } }})) - = setSrcSpan loc $ + = setSrcSpanA loc $ tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupLocatedTyCon lfam_name @@ -781,8 +781,8 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc) m_deriv_info = case derivs of - L _ [] -> Nothing - L _ preds -> + [] -> Nothing + preds -> Just $ DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs , di_clauses = preds @@ -1237,8 +1237,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Create the result bindings ; self_dict <- newDict clas inst_tys ; let class_tc = classTyCon clas + loc' = noAnnSrcSpan loc [dict_constr] = tyConDataCons class_tc - dict_bind = mkVarBind self_dict (L loc con_app_args) + dict_bind = mkVarBind self_dict (L loc' con_app_args) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application @@ -1257,8 +1258,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noExtField (L loc fun) - (L loc (wrapId arg_wrapper meth_id)) + app_to_meth fun meth_id = HsApp noComments (L loc' fun) + (L loc' (wrapId arg_wrapper meth_id)) inst_tv_tys = mkTyVarTys inst_tyvars arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys @@ -1285,7 +1286,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_binds = unitBag dict_bind , abs_sig = True } - ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds) + ; return (unitBag (L loc' main_bind) + `unionBags` sc_meth_binds) } where dfun_id = instanceDFunId ispec @@ -1324,7 +1326,7 @@ addDFunPrags dfun_id sc_meth_ids is_newtype = isNewTyCon clas_tc wrapId :: HsWrapper -> Id -> HsExpr GhcTc -wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id)) +wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1436,7 +1438,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta , abs_ev_binds = [dfun_ev_binds, local_ev_binds] , abs_binds = emptyBag , abs_sig = False } - ; return (sc_top_id, L loc bind, sc_implic) } + ; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) } ------------------- checkInstConstraints :: TcM result @@ -1655,7 +1657,7 @@ tcMethods :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds - -> ([Located TcSpecPrag], TcPragEnv) + -> ([LTcSpecPrag], TcPragEnv) -> [ClassOpItem] -> InstBindings GhcRn -> TcM ([Id], LHsBinds GhcTc, Bag Implication) @@ -1722,12 +1724,15 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys mkLHsWrap lam_wrapper (error_rhs dflags) ; return (meth_id, meth_bind, Nothing) } where - error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags) - error_fun = L inst_loc $ + inst_loc' = noAnnSrcSpan inst_loc + error_rhs dflags = L inst_loc' + $ HsApp noComments error_fun (error_msg dflags) + error_fun = L inst_loc' $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText + error_msg dflags = L inst_loc' + (HsLit noComments (HsStringPrim NoSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags @@ -1839,7 +1844,8 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) } + ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc) + (idName local_meth_id) } -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind @@ -1884,7 +1890,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind -- There is a signature in the instance -- See Note [Instance method signatures] = do { (sig_ty, hs_wrap) - <- setSrcSpan (getLoc hs_sig_ty) $ + <- setSrcSpan (getLocA hs_sig_ty) $ do { inst_sigs <- xoptM LangExt.InstanceSigs ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty @@ -1905,7 +1911,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind inner_meth_id = mkLocalId inner_meth_name Many sig_ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id , sig_ctxt = ctxt - , sig_loc = getLoc hs_sig_ty } + , sig_loc = getLocA hs_sig_ty } ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind @@ -2064,17 +2070,17 @@ mkDefMethBind dfun_id clas sel_id dm_name ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig noExtField fn inline_prag)] + = [noLocA (InlineSig noAnn fn inline_prag)] | otherwise = [] -- Copy the inline pragma (if any) from the default method -- to this version. Note [INLINE and default methods] - fn = noLoc (idName sel_id) + fn = noLocA (idName sel_id) visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys , tyConBinderArgFlag tcb /= Inferred ] rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys - bind = noLoc $ mkTopFunBind Generated fn $ + bind = noLocA $ mkTopFunBind Generated fn $ [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body" @@ -2087,8 +2093,8 @@ mkDefMethBind dfun_id clas sel_id dm_name (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id) mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy - $ noLoc $ XHsType ty)) + mk_vta fun ty = noLocA (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy + $ noLocA $ XHsType ty)) -- NB: use visible type application -- See Note [Default methods in instances] @@ -2281,9 +2287,9 @@ Note that -} tcSpecInstPrags :: DFunId -> InstBindings GhcRn - -> TcM ([Located TcSpecPrag], TcPragEnv) + -> TcM ([LTcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ + = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $ filter isSpecInstLSig uprags -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragEnv uprags binds) } diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 69a0d2898c..642429d61b 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -638,9 +638,9 @@ collectPatSynArgInfo details = InfixCon name1 name2 -> (map unLoc [name1, name2], True) RecCon names -> (map (unLoc . recordPatSynPatVar) names, False) -addPatSynCtxt :: Located Name -> TcM a -> TcM a +addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside - = setSrcSpan loc $ + = setSrcSpanA loc $ addErrCtxt (text "In the declaration for pattern synonym" <+> quotes (ppr name)) $ thing_inside @@ -654,7 +654,7 @@ wrongNumberOfParmsErr name decl_arity missing ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name +tc_patsyn_finish :: LocatedN Name -- ^ PatSyn Name -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat GhcTc -- ^ Pattern of the PatSyn @@ -737,7 +737,7 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ************************************************************************ -} -tcPatSynMatcher :: Located Name +tcPatSynMatcher :: LocatedN Name -> LPat GhcTc -> TcPragEnv -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar]) @@ -750,8 +750,9 @@ tcPatSynMatcher (L loc name) lpat prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty - = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc - ; tv_name <- newNameAt (mkTyVarOcc "r") loc + = do { let loc' = locA loc + ; rr_name <- newNameAt (mkTyVarOcc "rep") loc' + ; tv_name <- newNameAt (mkTyVarOcc "r") loc' ; let rr_tv = mkTyVar rr_name runtimeRepTy rr = mkTyVarTy rr_tv res_tv = mkTyVar tv_name (tYPE rr) @@ -782,7 +783,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn fail' = nlHsApps fail [nlHsVar voidPrimId] args = map nlVarPat [scrutinee, cont, fail] - lwpat = noLoc $ WildPat pat_ty + lwpat = noLocA $ WildPat pat_ty cases = if isIrrefutableHsPat dflags lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', @@ -790,23 +791,23 @@ tcPatSynMatcher (L loc name) lpat prag_fn body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ - MG{ mg_alts = L (getLoc lpat) cases + MG{ mg_alts = L (l2l $ getLoc lpat) cases , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty , mg_origin = Generated } - body' = noLoc $ + body' = noLocA $ HsLam noExtField $ - MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr - args body] + MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr + args body] , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated } match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') - (noLoc (EmptyLocalBinds noExtField)) + (EmptyLocalBinds noExtField) mg :: MatchGroup GhcTc (LHsExpr GhcTc) - mg = MG{ mg_alts = L (getLoc match) [match] + mg = MG{ mg_alts = L (l2l $ getLoc match) [match] , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated } @@ -818,7 +819,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn , fun_matches = mg , fun_ext = idHsWrapper , fun_tick = [] } - matcher_bind = unitBag (noLoc bind) + matcher_bind = unitBag (noLocA bind) ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) @@ -845,7 +846,7 @@ isUnidirectional ExplicitBidirectional{} = False ************************************************************************ -} -mkPatSynBuilder :: HsPatSynDir a -> Located Name +mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name -> [InvisTVBinder] -> ThetaType -> [InvisTVBinder] -> ThetaType -> [Type] -> Type @@ -879,7 +880,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLoc lpat) $ failWithTc $ + = setSrcSpan (getLocA lpat) $ failWithTc $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" <+> quotes (ppr ps_name) <> colon) 2 why @@ -919,7 +920,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) vcat [ ppr patsyn , ppr builder_id <+> dcolon <+> ppr (idType builder_id) , ppr prags ] - ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) + ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } @@ -934,13 +935,13 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated [builder_match] + mk_mg body = mkMatchGroup Generated (noLocA [builder_match]) where - builder_args = [L loc (VarPat noExtField (L loc n)) + builder_args = [L (na2la loc) (VarPat noExtField (L loc n)) | L loc n <- args] builder_match = mkMatch (mkPrefixFunRhs ps_lname) builder_args body - (noLoc (EmptyLocalBinds noExtField)) + (EmptyLocalBinds noExtField) args = case details of PrefixCon _ args -> args @@ -974,7 +975,7 @@ add_void need_dummy_arg ty | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty -tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn +tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn -> Either SDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), @@ -989,19 +990,22 @@ tcPatToExpr name args pat = go pat lhsVars = mkNameSet (map unLoc args) -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: Located Name -> [LPat GhcRn] + mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] -> Either SDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats - ; let con = L loc (HsVar noExtField lcon) + ; let con = L (l2l loc) (HsVar noExtField lcon) ; return (unLoc $ mkHsApps con exprs) } - mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) + mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn) -> Either SDoc (HsExpr GhcRn) - mkRecordConExpr con fields - = do { exprFields <- mapM go fields - ; return (RecordCon noExtField con exprFields) } + mkRecordConExpr con (HsRecFields fields dd) + = do { exprFields <- mapM go' fields + ; return (RecordCon noExtField con (HsRecFields exprFields dd)) } + + go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn)) + go' (L l rf) = L l <$> traverse go rf go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p @@ -1021,25 +1025,24 @@ tcPatToExpr name args pat = go pat = return $ HsVar noExtField (L l var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat + go1 (ParPat _ pat) = fmap (HsPar noAnn) $ go pat go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats ; return $ ExplicitList noExtField exprs } | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField - (map (noLoc . (Present noExtField)) exprs) - box } + (map (Present noAnn) exprs) box } go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) ; return $ ExplicitSum noExtField alt arity - (noLoc expr) + (noLocA expr) } - go1 (LitPat _ lit) = return $ HsLit noExtField lit + go1 (LitPat _ lit) = return $ HsLit noComments lit go1 (NPat _ (L _ n) mb_neg _) | Just (SyntaxExprRn neg) <- mb_neg - = return $ unLoc $ foldl' nlHsApp (noLoc neg) - [noLoc (HsOverLit noExtField n)] - | otherwise = return $ HsOverLit noExtField n + = return $ unLoc $ foldl' nlHsApp (noLocA neg) + [noLocA (HsOverLit noAnn n)] + | otherwise = return $ HsOverLit noAnn n go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go1 pat go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 8c7e764147..6c8daa0d56 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -242,7 +242,7 @@ checkSynCycles this_uid tcs tyclds = mod = nameModule n ppr_decl tc = case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr loc <> colon <+> ppr decl + Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n <+> text "from external module" where @@ -851,7 +851,8 @@ tcRecSelBinds sel_bind_prs tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs + sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id) + | (sel_id, _) <- sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] @@ -873,9 +874,11 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors -> (Id, LHsBind GhcRn) mkOneRecordSelector all_cons idDetails fl has_sel - = (sel_id, L loc sel_bind) + = (sel_id, L (noAnnSrcSpan loc) sel_bind) where loc = getSrcSpan sel_name + loc' = noAnnSrcSpan loc + locn = noAnnSrcSpan loc lbl = flLabel fl sel_name = flSelector fl @@ -913,18 +916,19 @@ mkOneRecordSelector all_cons idDetails fl has_sel [] unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [L loc (mk_sel_pat con)] - (L loc (HsVar noExtField (L loc field_var))) - mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields) + [L loc' (mk_sel_pat con)] + (L loc' (HsVar noExtField (L locn field_var))) + mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField - { hsRecFieldLbl + rec_field = noLocA (HsRecField + { hsRecFieldAnn = noAnn + , hsRecFieldLbl = L loc (FieldOcc sel_name - (L loc $ mkVarUnqual lbl)) + (L locn $ mkVarUnqual lbl)) , hsRecFieldArg - = L loc (VarPat noExtField (L loc field_var)) + = L loc' (VarPat noExtField (L locn field_var)) , hsRecPun = False }) - sel_lname = L loc sel_name + sel_lname = L locn sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive @@ -932,10 +936,10 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- mentions this particular record selector deflt | all dealt_with all_cons = [] | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat noExtField)] - (mkHsApp (L loc (HsVar noExtField - (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit noExtField msg_lit)))] + [L loc' (WildPat noExtField)] + (mkHsApp (L loc' (HsVar noExtField + (L locn (getName rEC_SEL_ERROR_ID)))) + (L loc' (HsLit noComments msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we @@ -966,7 +970,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel -- scenarios, eq_subst is an empty substitution. inst_tys = substTyVars eq_subst univ_tvs - unit_rhs = mkLHsTupleExpr [] + unit_rhs = mkLHsTupleExpr [] noExtField msg_lit = HsStringPrim NoSourceText (bytesFS lbl) {- diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 2c9be13dff..5da6364444 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -484,7 +484,7 @@ data TcGblEnv -- The binds, rules and foreign-decl fields are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)], + tcg_rn_exports :: Maybe [(LIE GhcRn, Avails)], -- Nothing <=> no explicit export list -- Is always Nothing if we don't want to retain renamed -- exports. diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index b1dd472d75..4ddb0ee000 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -479,7 +479,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin f +exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ hflLabel f) exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 066755e8f7..707d936504 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -185,7 +185,7 @@ checkHsigIface tcg_env gr sig_iface -- TODO: maybe we can be a little more -- precise here and use the Located -- info for the *specific* name we matched. - -> getLoc e + -> getLocA e _ -> nameSrcSpan name addErrAt loc (badReexportedBootThing False name name') @@ -611,7 +611,7 @@ mergeSignatures -- a signature package (i.e., does not expose any -- modules.) If so, we can thin it. | isFromSignaturePackage - -> setSrcSpan loc $ do + -> setSrcSpanA loc $ do -- Suppress missing errors; they might be used to refer -- to entities from other signatures we are merging in. -- If an identifier truly doesn't exist in any of the @@ -665,7 +665,7 @@ mergeSignatures is_mod = mod_name, is_as = mod_name, is_qual = False, - is_dloc = loc + is_dloc = locA loc } ImpAll rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1) setGblEnv tcg_env { diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index c38ad9491c..7ffd2f2f2c 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -229,10 +229,10 @@ span of the Name. -} -tcLookupLocatedGlobal :: Located Name -> TcM TyThing +tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing -- c.f. GHC.IfaceToCore.tcIfaceGlobal tcLookupLocatedGlobal name - = addLocM tcLookupGlobal name + = addLocMA tcLookupGlobal name tcLookupGlobal :: Name -> TcM TyThing -- The Name is almost always an ExternalName, but not always @@ -310,14 +310,14 @@ tcLookupAxiom name = do ACoAxiom ax -> return ax _ -> wrongThingErr "axiom" (AGlobal thing) name -tcLookupLocatedGlobalId :: Located Name -> TcM Id -tcLookupLocatedGlobalId = addLocM tcLookupId +tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id +tcLookupLocatedGlobalId = addLocMA tcLookupId -tcLookupLocatedClass :: Located Name -> TcM Class -tcLookupLocatedClass = addLocM tcLookupClass +tcLookupLocatedClass :: LocatedA Name -> TcM Class +tcLookupLocatedClass = addLocMA tcLookupClass -tcLookupLocatedTyCon :: Located Name -> TcM TyCon -tcLookupLocatedTyCon = addLocM tcLookupTyCon +tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon +tcLookupLocatedTyCon = addLocMA tcLookupTyCon -- Find the instance that exactly matches a type class application. The class arguments must be precisely -- the same as in the instance declaration (modulo renaming & casts). @@ -424,8 +424,8 @@ tcExtendRecEnv gbl_stuff thing_inside ************************************************************************ -} -tcLookupLocated :: Located Name -> TcM TcTyThing -tcLookupLocated = addLocM tcLookup +tcLookupLocated :: LocatedA Name -> TcM TcTyThing +tcLookupLocated = addLocMA tcLookup tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) tcLookupLcl_maybe name @@ -1056,12 +1056,12 @@ newDFunName clas tys loc ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } -newFamInstTyConName :: Located Name -> [Type] -> TcM Name -newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] +newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name +newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys] -newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name +newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name newFamInstAxiomName (L loc name) branches - = mk_fam_inst_name mkInstTyCoOcc loc name branches + = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name mk_fam_inst_name adaptOcc loc tc_name tyss diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 84e28a75e8..6238b6c36c 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -127,7 +127,7 @@ newMethodFromName origin name ty_args ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) instCall origin ty_args theta - ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) } + ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) } {- ************************************************************************ @@ -761,7 +761,7 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do -- same type as the standard one. -- Tiresome jiggling because tcCheckSigma takes a located expression span <- getSrcSpanM - expr <- tcCheckPolyExpr (L span user_nm_expr) sigma1 + expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1 return (std_nm, unLoc expr) syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 873c9b9fd2..1a70f0ecbd 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -61,8 +61,9 @@ module GHC.Tc.Utils.Monad( addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, addLocM, inGeneratedCode, - wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_, + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode, + wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, + wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, addErr, failWith, failAt, @@ -917,28 +918,57 @@ setSrcSpan loc@(UnhelpfulSpan _) thing_inside | otherwise = thing_inside +setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a +setSrcSpanA l = setSrcSpan (locA l) + addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a +addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b +addLocMA fn (L loc a) = setSrcSpanA loc $ fn a + wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a ; return (L loc b) } +wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b) +wrapLocAM fn (L loc a) = setSrcSpanA loc $ do { b <- fn a + ; return (L (locA loc) b) } + +wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b) +wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a + ; return (L loc b) } + wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) wrapLocFstM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a return (L loc b, c) +wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c) +wrapLocFstMA fn (L loc a) = + setSrcSpanA loc $ do + (b,c) <- fn a + return (L loc b, c) + wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) wrapLocSndM fn (L loc a) = setSrcSpan loc $ do (b,c) <- fn a return (b, L loc c) +wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c) +wrapLocSndMA fn (L loc a) = + setSrcSpanA loc $ do + (b,c) <- fn a + return (b, L loc c) + wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) +wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM () +wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a) + -- Reporting errors getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc)) diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 90717063f7..0e34d97c46 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -200,11 +200,11 @@ shortCutLit platform val res_ty where go_integral int@(IL src neg i) | isIntTy res_ty && platformInIntRange platform i - = Just (HsLit noExtField (HsInt noExtField int)) + = Just (HsLit noAnn (HsInt noExtField int)) | isWordTy res_ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) | isIntegerTy res_ty - = Just (HsLit noExtField (HsInteger src i res_ty)) + = Just (HsLit noAnn (HsInteger src i res_ty)) | otherwise = go_fractional (integralFractionalLit neg i) -- The 'otherwise' case is important @@ -225,11 +225,11 @@ shortCutLit platform val res_ty -- is less than 100, which ensures desugaring isn't slow. go_string src s - | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) + | isStringTy res_ty = Just (HsLit noAnn (HsString src s)) | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) +mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name @@ -412,7 +412,7 @@ zonkEnvIds (ZonkEnv { ze_id_env = id_env}) -- It's OK to use nonDetEltsUFM here because we forget the ordering -- immediately by creating a TypeEnv -zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id +zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id zonkLIdOcc env = mapLoc (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id @@ -569,7 +569,7 @@ zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) ; return (env2, (r,b'):bs') } zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do - new_binds <- mapM (wrapLocM zonk_ip_bind) binds + new_binds <- mapM (wrapLocMA zonk_ip_bind) binds let env1 = extendIdZonkEnvRec env [ n | (L _ (IPBind _ (Right n) _)) <- new_binds] @@ -594,7 +594,7 @@ zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc) zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc) -zonk_lbind env = wrapLocM (zonk_bind env) +zonk_lbind env = wrapLocMA (zonk_bind env) zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss @@ -733,10 +733,11 @@ zonkLTcSpecPrags env ps ************************************************************************ -} -zonkMatchGroup :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> MatchGroup GhcTc (Located (body GhcTc)) - -> TcM (MatchGroup GhcTc (Located (body GhcTc))) +zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> MatchGroup GhcTc (LocatedA (body GhcTc)) + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys res_ty , mg_origin = origin }) @@ -747,10 +748,11 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } -zonkMatch :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> LMatch GhcTc (Located (body GhcTc)) - -> TcM (LMatch GhcTc (Located (body GhcTc))) +zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> LMatch GhcTc (LocatedA (body GhcTc)) + -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) zonkMatch env zBody (L loc match@(Match { m_pats = pats , m_grhss = grhss })) = do { (env1, new_pats) <- zonkPats env pats @@ -758,12 +760,13 @@ zonkMatch env zBody (L loc match@(Match { m_pats = pats ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } ------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> GRHSs GhcTc (Located (body GhcTc)) - -> TcM (GRHSs GhcTc (Located (body GhcTc))) +zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> GRHSs GhcTc (LocatedA (body GhcTc)) + -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do +zonkGRHSs env zBody (GRHSs x grhss binds) = do (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS xx guarded rhs) @@ -771,7 +774,7 @@ zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do new_rhs <- zBody env2 rhs return (GRHS xx new_guarded new_rhs) new_grhss <- mapM (wrapLocM zonk_grhs) grhss - return (GRHSs x new_grhss (L l new_binds)) + return (GRHSs x new_grhss new_binds) {- ************************************************************************ @@ -786,7 +789,7 @@ zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc) zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocM (zonkExpr env) expr +zonkLExpr env expr = wrapLocMA (zonkExpr env) expr zonkExpr env (HsVar x (L l id)) = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) @@ -894,10 +897,10 @@ zonkExpr env (ExplicitTuple x tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args ; return (ExplicitTuple x new_tup_args boxed) } where - zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e - ; return (L l (Present x e')) } - zonk_tup_arg (L l (Missing t)) = do { t' <- zonkScaledTcTypeToTypeX env t - ; return (L l (Missing t')) } + zonk_tup_arg (Present x e) = do { e' <- zonkLExpr env e + ; return (Present x e') } + zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX env t + ; return (Missing t') } zonkExpr env (ExplicitSum args alt arity expr) @@ -925,10 +928,10 @@ zonkExpr env (HsMultiIf ty alts) ; expr' <- zonkLExpr env' expr ; return $ GRHS x guard' expr' } -zonkExpr env (HsLet x (L l binds) expr) +zonkExpr env (HsLet x binds expr) = do (new_env, new_binds) <- zonkLocalBinds env binds new_expr <- zonkLExpr new_env expr - return (HsLet x (L l new_binds) new_expr) + return (HsLet x new_binds new_expr) zonkExpr env (HsDo ty do_or_lc (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts @@ -1048,7 +1051,7 @@ zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc) zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc) zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc) -zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd +zonkLCmd env cmd = wrapLocMA (zonkCmd env) cmd zonkCmd env (XCmd (HsWrap w cmd)) = do { (env1, w') <- zonkCoFn env w @@ -1094,10 +1097,10 @@ zonkCmd env (HsCmdIf x eCond ePred cThen cElse) ; new_cElse <- zonkLCmd env1 cElse ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet x (L l binds) cmd) +zonkCmd env (HsCmdLet x binds cmd) = do (new_env, new_binds) <- zonkLocalBinds env binds new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x (L l new_binds) new_cmd) + return (HsCmdLet x new_binds new_cmd) zonkCmd env (HsCmdDo ty (L l stmts)) = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts @@ -1181,19 +1184,21 @@ zonkArithSeq env (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> [LStmt GhcTc (Located (body GhcTc))] - -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))]) +zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> [LStmt GhcTc (LocatedA (body GhcTc))] + -> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))]) zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s +zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndMA (zonkStmt env zBody) s ; (env2, ss') <- zonkStmts env1 zBody ss ; return (env2, s' : ss') } -zonkStmt :: ZonkEnv - -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc))) - -> Stmt GhcTc (Located (body GhcTc)) - -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc))) +zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => ZonkEnv + -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) + -> Stmt GhcTc (LocatedA (body GhcTc)) + -> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc))) zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty @@ -1213,7 +1218,8 @@ zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) new_return) } -zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs +zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs + , recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id , recS_bind_fn = bind_id , recS_ext = @@ -1235,7 +1241,8 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_ ; new_later_rets <- mapM (zonkExpr env5) later_rets ; new_rec_rets <- mapM (zonkExpr env5) rec_rets ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed - RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs + RecStmt { recS_stmts = noLocA new_segStmts + , recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id , recS_ext = RecStmtTc @@ -1283,9 +1290,9 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap newBinder' <- zonkIdBndr env newBinder return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (L l binds)) +zonkStmt env _ (LetStmt x binds) = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x (L l new_binds)) + return (env1, LetStmt x new_binds) zonkStmt env zBody (BindStmt xbs pat body) = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs) @@ -1398,7 +1405,7 @@ zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc) -- Extend the environment as we go, because it's possible for one -- pattern to bind something that is used in another (inside or -- to the right) -zonkPat env pat = wrapLocSndM (zonk_pat env) pat +zonkPat env pat = wrapLocSndMA (zonk_pat env) pat zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) zonk_pat env (ParPat x p) @@ -1530,7 +1537,7 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) zonk_pat env (XPat (CoPat co_fn pat ty)) = do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLoc pat) + ; (env'', pat') <- zonkPat env' (noLocA pat) ; ty' <- zonkTcTypeToTypeX env'' ty ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty') } @@ -1574,7 +1581,7 @@ zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc] -> TcM [LForeignDecl GhcTc] -zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls +zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc) zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co @@ -1586,7 +1593,7 @@ zonkForeignExport _ for_imp = return for_imp -- Foreign imports don't need zonking zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc] -zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs +zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc) zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index f446b69634..9a43e69c67 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -1864,7 +1864,7 @@ checkValidInstance ctxt hs_type ty = failWithTc (text "Arity mis-match in instance head") | otherwise - = do { setSrcSpan head_loc $ + = do { setSrcSpanA head_loc $ checkValidInstHead ctxt clas inst_tys ; traceTc "checkValidInstance {" (ppr ty) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 29976e4b89..1009ea72f0 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -53,7 +53,6 @@ import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Parser.Annotation import qualified Data.ByteString as BS import Control.Monad( unless, ap ) @@ -131,11 +130,18 @@ setL loc = CvtM (\_ _ -> Right (loc, ())) returnL :: a -> CvtM (Located a) returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -returnJustL :: a -> CvtM (Maybe (Located a)) -returnJustL = fmap Just . returnL +-- returnLA :: a -> CvtM (LocatedA a) +returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (ApiAnn' ann)) e) +returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) -wrapParL :: (Located a -> a) -> a -> CvtM a -wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x))) +returnJustLA :: a -> CvtM (Maybe (LocatedA a)) +returnJustLA = fmap Just . returnLA + +-- wrapParL :: (Located a -> a) -> a -> CvtM a +-- wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x))) + +wrapParLA :: (LocatedA a -> a) -> a -> CvtM a +wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x))) wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing @@ -156,6 +162,16 @@ wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of Left err -> Left err Right (loc', v) -> Right (loc', L loc v) +wrapLN :: CvtM a -> CvtM (LocatedN a) +wrapLN (CvtM m) = CvtM $ \origin loc -> case m origin loc of + Left err -> Left err + Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v) + +wrapLA :: CvtM a -> CvtM (LocatedA a) +wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of + Left err -> Left err + Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v) + ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs = fmap catMaybes . mapM cvtDec @@ -163,19 +179,19 @@ cvtDecs = fmap catMaybes . mapM cvtDec cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) cvtDec (TH.ValD pat body ds) | TH.VarP s <- pat - = do { s' <- vNameL s + = do { s' <- vNameN s ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) ; th_origin <- getOrigin - ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] } + ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] } | otherwise = do { pat' <- cvtPat pat ; body' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") ds - ; returnJustL $ Hs.ValD noExtField $ + ; returnJustLA $ Hs.ValD noExtField $ PatBind { pat_lhs = pat' - , pat_rhs = GRHSs noExtField body' (noLoc ds') - , pat_ext = noExtField + , pat_rhs = GRHSs noExtField body' ds' + , pat_ext = noAnn , pat_ticks = ([],[]) } } cvtDec (TH.FunD nm cls) @@ -184,30 +200,30 @@ cvtDec (TH.FunD nm cls) <+> quotes (text (TH.pprint nm)) <+> text "has no equations") | otherwise - = do { nm' <- vNameL nm + = do { nm' <- vNameN nm ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls ; th_origin <- getOrigin - ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' } + ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' } cvtDec (TH.SigD nm typ) - = do { nm' <- vNameL nm + = do { nm' <- vNameN nm ; ty' <- cvtSigType typ - ; returnJustL $ Hs.SigD noExtField - (TypeSig noExtField [nm'] (mkHsWildCardBndrs ty')) } + ; returnJustLA $ Hs.SigD noExtField + (TypeSig noAnn [nm'] (mkHsWildCardBndrs ty')) } cvtDec (TH.KiSigD nm ki) - = do { nm' <- tconNameL nm + = do { nm' <- tconNameN nm ; ki' <- cvtSigKind ki - ; let sig' = StandaloneKindSig noExtField nm' ki' - ; returnJustL $ Hs.KindSigD noExtField sig' } + ; let sig' = StandaloneKindSig noAnn nm' ki' + ; returnJustLA $ Hs.KindSigD noExtField sig' } cvtDec (TH.InfixD fx nm) -- Fixity signatures are allowed for variables, constructors, and types -- the renamer automatically looks for types during renaming, even when -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. - = do { nm' <- vcNameL nm - ; returnJustL (Hs.SigD noExtField (FixSig noExtField + = do { nm' <- vcNameN nm + ; returnJustLA (Hs.SigD noExtField (FixSig noAnn (FixitySig noExtField [nm'] (cvtFixity fx)))) } cvtDec (PragmaD prag) @@ -216,8 +232,8 @@ cvtDec (PragmaD prag) cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs - ; returnJustL $ TyClD noExtField $ - SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs' + ; returnJustLA $ TyClD noExtField $ + SynDecl { tcdSExt = noAnn, tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdRhs = rhs' } } @@ -237,13 +253,13 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField + ; let defn = HsDataDefn { dd_ext = noAnn , dd_ND = DataType, dd_cType = Nothing , dd_ctxt = Just ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } - ; returnJustL $ TyClD noExtField $ - DataDecl { tcdDExt = noExtField + ; returnJustLA $ TyClD noExtField $ + DataDecl { tcdDExt = noAnn , tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdDataDefn = defn } } @@ -253,14 +269,14 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) ; ksig' <- cvtKind `traverse` ksig ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField + ; let defn = HsDataDefn { dd_ext = noAnn , dd_ND = NewType, dd_cType = Nothing , dd_ctxt = Just ctxt' , dd_kindSig = ksig' , dd_cons = [con'] , dd_derivs = derivs' } - ; returnJustL $ TyClD noExtField $ - DataDecl { tcdDExt = noExtField + ; returnJustLA $ TyClD noExtField $ + DataDecl { tcdDExt = noAnn , tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdDataDefn = defn } } @@ -273,8 +289,8 @@ cvtDec (ClassD ctxt cl tvs fds decs) (failWith $ (text "Default data instance declarations" <+> text "are not allowed:") $$ (Outputable.ppr adts')) - ; returnJustL $ TyClD noExtField $ - ClassDecl { tcdCExt = NoLayoutInfo + ; returnJustLA $ TyClD noExtField $ + ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo) , tcdCtxt = Just cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' @@ -291,12 +307,13 @@ cvtDec (InstanceD o ctxt ty decs) ; (L loc ty') <- cvtType ty ; let inst_ty' = L loc $ mkHsImplicitSigType $ mkHsQualTy ctxt loc ctxt' $ L loc ty' - ; returnJustL $ InstD noExtField $ ClsInstD noExtField $ - ClsInstDecl { cid_ext = noExtField, cid_poly_ty = inst_ty' + ; returnJustLA $ InstD noExtField $ ClsInstD noExtField $ + ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts' - , cid_overlap_mode = fmap (L loc . overlap) o } } + , cid_overlap_mode + = fmap (L (l2l loc) . overlap) o } } where overlap pragma = case pragma of @@ -310,29 +327,29 @@ cvtDec (InstanceD o ctxt ty decs) cvtDec (ForeignD ford) = do { ford' <- cvtForD ford - ; returnJustL $ ForD noExtField ford' } + ; returnJustLA $ ForD noExtField ford' } cvtDec (DataFamilyD tc tvs kind) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; result <- cvtMaybeKindToFamilyResultSig kind - ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ - FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing } + ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noAnn DataFamily TopLevel tc' tvs' Prefix result Nothing } cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField + ; let defn = HsDataDefn { dd_ext = noAnn , dd_ND = DataType, dd_cType = Nothing , dd_ctxt = Just ctxt' , dd_kindSig = ksig' , dd_cons = cons', dd_derivs = derivs' } - ; returnJustL $ InstD noExtField $ DataFamInstD - { dfid_ext = noExtField + ; returnJustLA $ InstD noExtField $ DataFamInstD + { dfid_ext = noAnn , dfid_inst = DataFamInstDecl { dfid_eqn = - FamEqn { feqn_ext = noExtField + FamEqn { feqn_ext = noAnn , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = typats' @@ -344,15 +361,15 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) ; ksig' <- cvtKind `traverse` ksig ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField + ; let defn = HsDataDefn { dd_ext = noAnn , dd_ND = NewType, dd_cType = Nothing , dd_ctxt = Just ctxt' , dd_kindSig = ksig' , dd_cons = [con'], dd_derivs = derivs' } - ; returnJustL $ InstD noExtField $ DataFamInstD - { dfid_ext = noExtField + ; returnJustLA $ InstD noExtField $ DataFamInstD + { dfid_ext = noAnn , dfid_inst = DataFamInstDecl { dfid_eqn = - FamEqn { feqn_ext = noExtField + FamEqn { feqn_ext = noAnn , feqn_tycon = tc' , feqn_bndrs = bndrs' , feqn_pats = typats' @@ -361,27 +378,28 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) cvtDec (TySynInstD eqn) = do { (L _ eqn') <- cvtTySynEqn eqn - ; returnJustL $ InstD noExtField $ TyFamInstD + ; returnJustLA $ InstD noExtField $ TyFamInstD { tfid_ext = noExtField - , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } + , tfid_inst = TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = eqn' } }} cvtDec (OpenTypeFamilyD head) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head - ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ - FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity' + ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noAnn OpenTypeFamily TopLevel tc' tyvars' Prefix result' injectivity' } cvtDec (ClosedTypeFamilyD head eqns) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head ; eqns' <- mapM cvtTySynEqn eqns - ; returnJustL $ TyClD noExtField $ FamDecl noExtField $ - FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix + ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $ + FamilyDecl noAnn (ClosedTypeFamily (Just eqns')) TopLevel tc' tyvars' Prefix result' injectivity' } cvtDec (TH.RoleAnnotD tc roles) - = do { tc' <- tconNameL tc + = do { tc' <- tconNameN tc ; let roles' = map (noLoc . cvtRole) roles - ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') } + ; returnJustLA + $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') } cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext funPrec cxt @@ -389,44 +407,45 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) ; (L loc ty') <- cvtType ty ; let inst_ty' = L loc $ mkHsImplicitSigType $ mkHsQualTy cxt loc cxt' $ L loc ty' - ; returnJustL $ DerivD noExtField $ - DerivDecl { deriv_ext =noExtField + ; returnJustLA $ DerivD noExtField $ + DerivDecl { deriv_ext = noAnn , deriv_strategy = ds' , deriv_type = mkHsWildCardBndrs inst_ty' , deriv_overlap_mode = Nothing } } cvtDec (TH.DefaultSigD nm typ) - = do { nm' <- vNameL nm + = do { nm' <- vNameN nm ; ty' <- cvtSigType typ - ; returnJustL $ Hs.SigD noExtField - $ ClassOpSig noExtField True [nm'] ty'} + ; returnJustLA $ Hs.SigD noExtField + $ ClassOpSig noAnn True [nm'] ty'} cvtDec (TH.PatSynD nm args dir pat) - = do { nm' <- cNameL nm + = do { nm' <- cNameN nm ; args' <- cvtArgs args ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat - ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $ - PSB noExtField nm' args' pat' dir' } + ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $ + PSB noAnn nm' args' pat' dir' } where - cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameL args - cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 + cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args + cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2 cvtArgs (TH.RecordPatSyn sels) - = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameL) sels - ; vars' <- mapM (vNameL . mkNameS . nameBase) sels + = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameN) sels + ; vars' <- mapM (vNameN . mkNameS . nameBase) sels ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } + -- cvtDir :: LocatedN RdrName -> (PatSynDir -> CvtM (HsPatSynDir RdrName)) cvtDir _ Unidir = return Unidirectional cvtDir _ ImplBidir = return ImplicitBidirectional cvtDir n (ExplBidir cls) = do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls ; th_origin <- getOrigin - ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms } + ; return $ ExplicitBidirectional $ mkMatchGroup th_origin (noLocA ms) } cvtDec (TH.PatSynSigD nm ty) - = do { nm' <- cNameL nm + = do { nm' <- cNameN nm ; ty' <- cvtPatSynSigTy ty - ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] ty'} + ; returnJustLA $ Hs.SigD noExtField $ PatSynSig noAnn [nm'] ty'} -- Implicit parameter bindings are handled in cvtLocalDecs and -- cvtImplicitParamBind. They are not allowed in any other scope, so @@ -441,21 +460,21 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs mb_bndrs' ; (head_ty, args) <- split_ty_app lhs ; case head_ty of - ConT nm -> do { nm' <- tconNameL nm + ConT nm -> do { nm' <- tconNameN nm ; rhs' <- cvtType rhs ; let args' = map wrap_tyarg args - ; returnL - $ FamEqn { feqn_ext = noExtField + ; returnLA + $ FamEqn { feqn_ext = noAnn , feqn_tycon = nm' , feqn_bndrs = outer_bndrs , feqn_pats = args' , feqn_fixity = Prefix , feqn_rhs = rhs' } } - InfixT t1 nm t2 -> do { nm' <- tconNameL nm + InfixT t1 nm t2 -> do { nm' <- tconNameN nm ; args' <- mapM cvtType [t1,t2] ; rhs' <- cvtType rhs - ; returnL - $ FamEqn { feqn_ext = noExtField + ; returnLA + $ FamEqn { feqn_ext = noAnn , feqn_tycon = nm' , feqn_bndrs = outer_bndrs , feqn_pats = @@ -488,18 +507,18 @@ cvt_ci_decs doc decs ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] -> CvtM ( LHsContext GhcPs - , Located RdrName + , LocatedN RdrName , LHsQTyVars GhcPs) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext funPrec cxt - ; tc' <- tconNameL tc + ; tc' <- tconNameN tc ; tvs' <- cvtTvs tvs ; return (cxt', tc', mkHsQTvs tvs') } cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type -> CvtM ( LHsContext GhcPs - , Located RdrName + , LocatedN RdrName , HsOuterFamEqnTyVarBndrs GhcPs , HsTyPats GhcPs) cvt_datainst_hdr cxt bndrs tys @@ -508,10 +527,10 @@ cvt_datainst_hdr cxt bndrs tys ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs bndrs' ; (head_ty, args) <- split_ty_app tys ; case head_ty of - ConT nm -> do { nm' <- tconNameL nm + ConT nm -> do { nm' <- tconNameN nm ; let args' = map wrap_tyarg args ; return (cxt', nm', outer_bndrs, args') } - InfixT t1 nm t2 -> do { nm' <- tconNameL nm + InfixT t1 nm t2 -> do { nm' <- tconNameN nm ; args' <- mapM cvtType [t1,t2] ; return (cxt', nm', outer_bndrs, ((map HsValArg args') ++ args)) } @@ -520,7 +539,7 @@ cvt_datainst_hdr cxt bndrs tys ---------------- cvt_tyfam_head :: TypeFamilyHead - -> CvtM ( Located RdrName + -> CvtM ( LocatedN RdrName , LHsQTyVars GhcPs , Hs.LFamilyResultSig GhcPs , Maybe (Hs.LInjectivityAnn GhcPs)) @@ -576,28 +595,28 @@ mkBadDecMsg doc bads cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) cvtConstr (NormalC c strtys) - = do { c' <- cNameL c + = do { c' <- cNameN c ; tys' <- mapM cvt_arg strtys - ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) } + ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) } cvtConstr (RecC c varstrtys) - = do { c' <- cNameL c + = do { c' <- cNameN c ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkConDeclH98 c' Nothing Nothing - (RecCon (noLoc args')) } + ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing + (RecCon (noLocA args')) } cvtConstr (InfixC st1 c st2) - = do { c' <- cNameL c + = do { c' <- cNameN c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon (hsLinear st1') - (hsLinear st2')) } + ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing + (InfixCon (hsLinear st1') (hsLinear st2')) } cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt ; L _ con' <- cvtConstr con - ; returnL $ add_forall tvs' ctxt' con' } + ; returnLA $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = Just lcxt add_cxt (L loc cxt1) (Just (L _ cxt2)) @@ -611,14 +630,14 @@ cvtConstr (ForallC tvs ctxt con) where outer_bndrs' | null all_tvs = mkHsOuterImplicit - | otherwise = mkHsOuterExplicit all_tvs + | otherwise = mkHsOuterExplicit noAnn all_tvs all_tvs = tvs' ++ outer_exp_tvs outer_exp_tvs = hsOuterExplicitBndrs outer_bndrs add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) - = con { con_forall = noLoc $ not (null all_tvs) + = con { con_forall = not (null all_tvs) , con_ex_tvs = all_tvs , con_mb_cxt = add_cxt cxt' cxt } where @@ -628,26 +647,26 @@ cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name") cvtConstr (GadtC c strtys ty) - = do { c' <- mapM cNameL c + = do { c' <- mapM cNameN c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty - ; returnL $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} + ; returnLA $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name") cvtConstr (RecGadtC c varstrtys ty) - = do { c' <- mapM cNameL c + = do { c' <- mapM cNameN c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; returnL $ mk_gadt_decl c' (RecConGADT $ noLoc rec_flds) ty' } + ; returnLA $ mk_gadt_decl c' (RecConGADT $ noLocA rec_flds) ty' } -mk_gadt_decl :: [Located RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs +mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs mk_gadt_decl names args res_ty - = ConDeclGADT { con_g_ext = noExtField + = ConDeclGADT { con_g_ext = noAnn , con_names = names - , con_bndrs = noLoc mkHsOuterImplicit + , con_bndrs = noLocA mkHsOuterImplicit , con_mb_cxt = Nothing , con_g_args = args , con_res_ty = res_ty @@ -669,27 +688,27 @@ cvt_arg (Bang su ss, ty) ; let ty' = parenthesizeHsType appPrec ty'' su' = cvtSrcUnpackedness su ss' = cvtSrcStrictness ss - ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' } + ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' } cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty) - = do { L li i' <- vNameL i + = do { L li i' <- vNameN i ; ty' <- cvt_arg (str,ty) - ; return $ noLoc (ConDeclField - { cd_fld_ext = noExtField + ; return $ noLocA (ConDeclField + { cd_fld_ext = noAnn , cd_fld_names - = [L li $ FieldOcc noExtField (L li i')] + = [L (locA li) $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs - ; returnL cs' } + ; return cs' } -cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs) -cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs - ; ys' <- mapM tNameL ys - ; returnL (xs', ys') } +cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs) +cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs + ; ys' <- mapM tNameN ys + ; returnLA (Hs.FunDep noAnn xs' ys') } ------------------------------------------ @@ -714,9 +733,9 @@ cvtForD (ImportF callconv safety from nm ty) = failWith $ text (show from) <+> text "is not a valid ccall impent" where mk_imp impspec - = do { nm' <- vNameL nm + = do { nm' <- vNameN nm ; ty' <- cvtSigType ty - ; return (ForeignImport { fd_i_ext = noExtField + ; return (ForeignImport { fd_i_ext = noAnn , fd_name = nm' , fd_sig_ty = ty' , fd_fi = impspec }) @@ -727,13 +746,13 @@ cvtForD (ImportF callconv safety from nm ty) Interruptible -> PlayInterruptible cvtForD (ExportF callconv as nm ty) - = do { nm' <- vNameL nm + = do { nm' <- vNameN nm ; ty' <- cvtSigType ty ; let e = CExport (noLoc (CExportStatic (SourceText as) (mkFastString as) (cvt_conv callconv))) (noLoc (SourceText as)) - ; return $ ForeignExport { fd_e_ext = noExtField + ; return $ ForeignExport { fd_e_ext = noAnn , fd_name = nm' , fd_sig_ty = ty' , fd_fe = e } } @@ -751,7 +770,7 @@ cvt_conv TH.JavaScript = JavaScriptCallConv cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) cvtPragmaD (InlineP nm inline rm phases) - = do { nm' <- vNameL nm + = do { nm' <- vNameN nm ; let dflt = dfltActivation inline ; let src TH.NoInline = "{-# NOINLINE" src TH.Inline = "{-# INLINE" @@ -761,10 +780,10 @@ cvtPragmaD (InlineP nm inline rm phases) , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip } + ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } cvtPragmaD (SpecialiseP nm ty inline phases) - = do { nm' <- vNameL nm + = do { nm' <- vNameN nm ; ty' <- cvtSigType ty ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" src TH.Inline = "{-# SPECIALISE INLINE" @@ -779,12 +798,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [ty'] ip } + ; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtSigType ty - ; returnJustL $ Hs.SigD noExtField $ - SpecInstSig noExtField (SourceText "{-# SPECIALISE") ty' } + ; returnJustLA $ Hs.SigD noExtField $ + SpecInstSig noAnn (SourceText "{-# SPECIALISE") ty' } cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -793,11 +812,11 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs - ; returnJustL $ Hs.RuleD noExtField - $ HsRules { rds_ext = noExtField + ; returnJustLA $ Hs.RuleD noExtField + $ HsRules { rds_ext = noAnn , rds_src = SourceText "{-# RULES" - , rds_rules = [noLoc $ - HsRule { rd_ext = noExtField + , rds_rules = [noLocA $ + HsRule { rd_ext = noAnn , rd_name = (noLoc (quotedSourceText nm,nm')) , rd_act = act , rd_tyvs = ty_bndrs' @@ -813,12 +832,12 @@ cvtPragmaD (AnnP target exp) ModuleAnnotation -> return ModuleAnnProvenance TypeAnnotation n -> do n' <- tconName n - return (TypeAnnProvenance (noLoc n')) + return (TypeAnnProvenance (noLocA n')) ValueAnnotation n -> do n' <- vcName n - return (ValueAnnProvenance (noLoc n')) - ; returnJustL $ Hs.AnnD noExtField - $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp' + return (ValueAnnProvenance (noLocA n')) + ; returnJustLA $ Hs.AnnD noExtField + $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp' } cvtPragmaD (LineP line file) @@ -826,10 +845,10 @@ cvtPragmaD (LineP line file) ; return Nothing } cvtPragmaD (CompleteP cls mty) - = do { cls' <- noLoc <$> mapM cNameL cls - ; mty' <- traverse tconNameL mty - ; returnJustL $ Hs.SigD noExtField - $ CompleteMatchSig noExtField NoSourceText cls' mty' } + = do { cls' <- noLoc <$> mapM cNameN cls + ; mty' <- traverse tconNameN mty + ; returnJustLA $ Hs.SigD noExtField + $ CompleteMatchSig noAnn NoSourceText cls' mty' } dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive @@ -851,12 +870,12 @@ cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) - = do { n' <- vNameL n - ; return $ noLoc $ Hs.RuleBndr noExtField n' } + = do { n' <- vNameN n + ; return $ noLoc $ Hs.RuleBndr noAnn n' } cvtRuleBndr (TypedRuleVar n ty) - = do { n' <- vNameL n + = do { n' <- vNameN n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkHsPatSigType ty' } + ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType ty' } --------------------------------------------------- -- Declarations @@ -871,10 +890,10 @@ cvtLocalDecs doc ds let (binds, prob_sigs) = partitionWith is_bind ds' let (sigs, bads) = partitionWith is_sig prob_sigs unless (null bads) (failWith (mkBadDecMsg doc bads)) - return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs)) + return (HsValBinds noAnn (ValBinds NoAnnSortKey (listToBag binds) sigs)) (ip_binds, []) -> do binds <- mapM (uncurry cvtImplicitParamBind) ip_binds - return (HsIPBinds noExtField (IPBinds noExtField binds)) + return (HsIPBinds noAnn (IPBinds noExtField binds)) ((_:_), (_:_)) -> failWith (text "Implicit parameters mixed with other bindings") @@ -885,27 +904,27 @@ cvtClause ctxt (Clause ps body wheres) ; let pps = map (parenthesizePat appPrec) ps' ; g' <- cvtGuard body ; ds' <- cvtLocalDecs (text "a where clause") wheres - ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) } + ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs noExtField g' ds') } cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) cvtImplicitParamBind n e = do n' <- wrapL (ipName n) e' <- cvtl e - returnL (IPBind noExtField (Left n') e') + returnLA (IPBind noAnn (Left n') e') ------------------------------------------------------------------- -- Expressions ------------------------------------------------------------------- cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) -cvtl e = wrapL (cvt e) +cvtl e = wrapLA (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar noExtField (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar noExtField (noLoc s') } + cvt (VarE s) = do { s' <- vName s; return $ HsVar noExtField (noLocA s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar noExtField (noLocA s') } cvt (LitE l) - | overloadedLit l = go cvtOverLit (HsOverLit noExtField) + | overloadedLit l = go cvtOverLit (HsOverLit noComments) (hsOverLitNeedsParens appPrec) - | otherwise = go cvtLit (HsLit noExtField) + | otherwise = go cvtLit (HsLit noComments) (hsLitNeedsParens appPrec) where go :: (Lit -> CvtM (l GhcPs)) @@ -915,17 +934,17 @@ cvtl e = wrapL (cvt e) go cvt_lit mk_expr is_compound_lit = do l' <- cvt_lit l let e' = mk_expr l' - return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e' + return $ if is_compound_lit l' then HsPar noAnn (noLocA e') else e' cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noExtField (mkLHsPar x') + ; return $ HsApp noComments (mkLHsPar x') (mkLHsPar y')} cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noExtField (mkLHsPar x') + ; return $ HsApp noComments (mkLHsPar x') (mkLHsPar y')} cvt (AppTypeE e t) = do { e' <- cvtl e ; t' <- cvtType t ; let tp = parenthesizeHsType appPrec t' - ; return $ HsAppType noExtField e' + ; return $ HsAppType noSrcSpan e' $ mkHsWildCardBndrs tp } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing @@ -935,42 +954,42 @@ cvtl e = wrapL (cvt e) ; let pats = map (parenthesizePat appPrec) ps' ; th_origin <- getOrigin ; return $ HsLam noExtField (mkMatchGroup th_origin - [mkSimpleMatch LambdaExpr - pats e'])} + (noLocA [mkSimpleMatch LambdaExpr + pats e']))} cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin - ; return $ HsLamCase noExtField - (mkMatchGroup th_origin ms') + ; return $ HsLamCase noAnn + (mkMatchGroup th_origin (noLocA ms')) } cvt (TupE es) = cvt_tup es Boxed cvt (UnboxedTupE es) = cvt_tup es Unboxed cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e ; unboxedSumChecks alt arity - ; return $ ExplicitSum noExtField + ; return $ ExplicitSum noAnn alt arity e'} cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; - ; return $ mkHsIf x' y' z' } + ; return $ mkHsIf x' y' z' noAnn } cvt (MultiIfE alts) | null alts = failWith (text "Multi-way if-expression with no alternatives") | otherwise = do { alts' <- mapM cvtpair alts - ; return $ HsMultiIf noExtField alts' } + ; return $ HsMultiIf noAnn alts' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds - ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'} + ; e' <- cvtl e; return $ HsLet noAnn ds' e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin - ; return $ HsCase noExtField e' - (mkMatchGroup th_origin ms') } + ; return $ HsCase noAnn e' + (mkMatchGroup th_origin (noLocA ms')) } cvt (DoE m ss) = cvtHsDo (DoExpr (mk_mod <$> m)) ss cvt (MDoE m ss) = cvtHsDo (MDoExpr (mk_mod <$> m)) ss cvt (CompE ss) = cvtHsDo ListComp ss cvt (ArithSeqE dd) = do { dd' <- cvtDD dd - ; return $ ArithSeq noExtField Nothing dd' } + ; return $ ArithSeq noAnn Nothing dd' } cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) - ; return (HsLit noExtField l') } + ; return (HsLit noComments l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList noExtField xs' + ; return $ ExplicitList noAnn xs' } -- Infix expressions @@ -980,25 +999,25 @@ cvtl e = wrapL (cvt e) ; y' <- cvtl y ; let px = parenthesizeHsExpr opPrec x' py = parenthesizeHsExpr opPrec y' - ; wrapParL (HsPar noExtField) - $ OpApp noExtField px s' py } + ; wrapParLA (HsPar noAnn) + $ OpApp noAnn px s' py } -- Parenthesise both arguments and result, -- to ensure this operator application does -- does not get re-associated -- See Note [Operator association] cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ do { s' <- cvtl s; y' <- cvtl y - ; wrapParL (HsPar noExtField) $ - SectionR noExtField s' y' } + ; wrapParLA (HsPar noAnn) $ + SectionR noComments s' y' } -- See Note [Sections in HsSyn] in GHC.Hs.Expr cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ do { x' <- cvtl x; s' <- cvtl s - ; wrapParL (HsPar noExtField) $ - SectionL noExtField x' s' } + ; wrapParLA (HsPar noAnn) $ + SectionL noComments x' s' } cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ do { s' <- cvtl s - ; return $ HsPar noExtField s' } + ; return $ HsPar noAnn s' } -- Can I indicate this is an infix thing? -- Note [Dropping constructors] @@ -1009,26 +1028,26 @@ cvtl e = wrapL (cvt e) _ -> mkLHsPar x' ; cvtOpApp x'' s y } -- Note [Converting UInfix] - cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExtField e' } + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noAnn e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtSigType t ; let pe = parenthesizeHsExpr sigPrec e' - ; return $ ExprWithTySig noExtField pe (mkHsWildCardBndrs t') } - cvt (RecConE c flds) = do { c' <- cNameL c - ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds - ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } + ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') } + cvt (RecConE c flds) = do { c' <- cNameN c + ; flds' <- mapM (cvtFld (mkFieldOcc . noLocA)) flds + ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn } cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' - <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) + <- mapM (cvtFld (mkAmbiguousFieldOcc . noLocA)) flds - ; return $ RecordUpd noExtField e' (Left flds') } - cvt (StaticE e) = fmap (HsStatic noExtField) $ cvtl e + ; return $ RecordUpd noAnn e' (Left flds') } + cvt (StaticE e) = fmap (HsStatic noAnn) $ cvtl e cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is -- important, because UnboundVarE may contain -- constructor names - see #14627. { s' <- vcName s - ; return $ HsVar noExtField (noLoc s') } - cvt (LabelE s) = return $ HsOverLabel noExtField (fsLit s) - cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } + ; return $ HsVar noExtField (noLocA s') } + cvt (LabelE s) = return $ HsOverLabel noComments (fsLit s) + cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' } {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: @@ -1064,12 +1083,13 @@ which we don't want. -} cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) - -> CvtM (LHsRecField' t (LHsExpr GhcPs)) + -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs)) cvtFld f (v,e) = do { v' <- vNameL v; e' <- cvtl e - ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v' - , hsRecFieldArg = e' - , hsRecPun = False}) } + ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn + , hsRecFieldLbl = reLoc $ fmap f v' + , hsRecFieldArg = e' + , hsRecPun = False}) } cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } @@ -1078,12 +1098,12 @@ cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) -cvt_tup es boxity = do { let cvtl_maybe Nothing = return missingTupArg - cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e) +cvt_tup es boxity = do { let cvtl_maybe Nothing = return (missingTupArg noAnn) + cvtl_maybe (Just e) = fmap (Present noAnn) (cvtl e) ; es' <- mapM cvtl_maybe es ; return $ ExplicitTuple - noExtField - (map noLoc es') + noAnn + es' boxity } {- Note [Operator association] @@ -1140,12 +1160,12 @@ since we have already run @cvtl@ on it. -} cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) cvtOpApp x op1 (UInfixE y op2 z) - = do { l <- wrapL $ cvtOpApp x op1 y + = do { l <- wrapLA $ cvtOpApp x op1 y ; cvtOpApp l op2 z } cvtOpApp x op y = do { op' <- cvtl op ; y' <- cvtl y - ; return (OpApp noExtField x op' y') } + ; return (OpApp noAnn x op' y') } ------------------------------------- -- Do notation and statements @@ -1163,7 +1183,7 @@ cvtHsDo do_or_lc stmts -> return (L loc (mkLastStmt body)) _ -> failWith (bad_last last') - ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) } + ; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) } where bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt @@ -1173,39 +1193,39 @@ cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] cvtStmts = mapM cvtStmt cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) -cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' } -cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkPsBindStmt p' e' } +cvtStmt (NoBindS e) = do { e' <- cvtl e; returnLA $ mkBodyStmt e' } +cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds - ; returnL $ LetStmt noExtField (noLoc ds') } + ; returnLA $ LetStmt noAnn ds' } cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss - ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr } + ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr } where cvt_one ds = do { ds' <- cvtStmts ds ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } -cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') } +cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnLA (mkRecStmt noAnn (noLocA ss')) } cvtMatch :: HsMatchContext GhcPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of - (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875 + (L loc SigPat{}) -> L loc (ParPat noAnn p') -- #14875 _ -> p' ; g' <- cvtGuard body ; decs' <- cvtLocalDecs (text "a where clause") decs - ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) } + ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs noExtField g' decs') } cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e - ; g' <- returnL $ GRHS noExtField [] e'; return [g'] } + ; g' <- returnL $ GRHS noAnn [] e'; return [g'] } cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs - ; g' <- returnL $ mkBodyStmt ge' - ; returnL $ GRHS noExtField [g'] rhs' } + ; g' <- returnLA $ mkBodyStmt ge' + ; returnL $ GRHS noAnn [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs - ; returnL $ GRHS noExtField gs' rhs' } + ; returnL $ GRHS noAnn gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) @@ -1273,39 +1293,39 @@ cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs] cvtPats pats = mapM cvtPat pats cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs) -cvtPat pat = wrapL (cvtp pat) +cvtPat pat = wrapLA (cvtp pat) cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l - ; return (mkNPat (noLoc l') Nothing) } + ; return (mkNPat (noLoc l') Nothing noAnn) } -- Not right for negative patterns; -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } cvtp (TH.VarP s) = do { s' <- vName s - ; return $ Hs.VarPat noExtField (noLoc s') } + ; return $ Hs.VarPat noExtField (noLocA s') } cvtp (TupP ps) = do { ps' <- cvtPats ps - ; return $ TuplePat noExtField ps' Boxed } + ; return $ TuplePat noAnn ps' Boxed } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps - ; return $ TuplePat noExtField ps' Unboxed } + ; return $ TuplePat noAnn ps' Unboxed } cvtp (UnboxedSumP p alt arity) = do { p' <- cvtPat p ; unboxedSumChecks alt arity - ; return $ SumPat noExtField p' alt arity } -cvtp (ConP s ts ps) = do { s' <- cNameL s + ; return $ SumPat noAnn p' alt arity } +cvtp (ConP s ts ps) = do { s' <- cNameN s ; ps' <- cvtPats ps ; ts' <- mapM cvtType ts ; let pps = map (parenthesizePat appPrec) ps' ; return $ ConPat - { pat_con_ext = noExtField + { pat_con_ext = noAnn , pat_con = s' , pat_args = PrefixCon (map mkHsPatSigType ts') pps } } -cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; wrapParL (ParPat noExtField) $ +cvtp (InfixP p1 s p2) = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2 + ; wrapParLA (ParPat noAnn) $ ConPat - { pat_con_ext = NoExtField + { pat_con_ext = noAnn , pat_con = s' , pat_args = InfixCon (parenthesizePat opPrec p1') @@ -1317,35 +1337,36 @@ cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Co cvtp (ParensP p) = do { p' <- cvtPat p; ; case unLoc p' of -- may be wrapped ConPatIn ParPat {} -> return $ unLoc p' - _ -> return $ ParPat noExtField p' } -cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExtField p' } -cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExtField p' } -cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p - ; return $ AsPat noExtField s' p' } + _ -> return $ ParPat noAnn p' } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noAnn p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noAnn p' } +cvtp (TH.AsP s p) = do { s' <- vNameN s; p' <- cvtPat p + ; return $ AsPat noAnn s' p' } cvtp TH.WildP = return $ WildPat noExtField -cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs +cvtp (RecP c fs) = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs ; return $ ConPat - { pat_con_ext = noExtField + { pat_con_ext = noAnn , pat_con = c' , pat_args = Hs.RecCon $ HsRecFields fs' Nothing } } cvtp (ListP ps) = do { ps' <- cvtPats ps ; return - $ ListPat noExtField ps'} + $ ListPat noAnn ps'} cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPat noExtField p' (mkHsPatSigType t') } + ; return $ SigPat noAnn p' (mkHsPatSigType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p - ; return $ ViewPat noExtField e' p'} + ; return $ ViewPat noAnn e' p'} cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p) - = do { L ls s' <- vNameL s + = do { L ls s' <- vNameN s ; p' <- cvtPat p - ; return (noLoc $ HsRecField { hsRecFieldLbl - = L ls $ mkFieldOcc (L ls s') - , hsRecFieldArg = p' - , hsRecPun = False}) } + ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn + , hsRecFieldLbl + = L (locA ls) $ mkFieldOcc (L ls s') + , hsRecFieldArg = p' + , hsRecPun = False}) } {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is. @@ -1354,13 +1375,13 @@ See the @cvtOpApp@ documentation for how this function works. -} cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) cvtOpAppP x op1 (UInfixP y op2 z) - = do { l <- wrapL $ cvtOpAppP x op1 y + = do { l <- wrapLA $ cvtOpAppP x op1 y ; cvtOpAppP l op2 z } cvtOpAppP x op y - = do { op' <- cNameL op + = do { op' <- cNameN op ; y' <- cvtPat y ; return $ ConPat - { pat_con_ext = noExtField + { pat_con_ext = noAnn , pat_con = op' , pat_args = InfixCon x y' } @@ -1384,14 +1405,14 @@ cvtTvs tvs = mapM cvt_tv tvs cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs) cvt_tv (TH.PlainTV nm fl) - = do { nm' <- tNameL nm + = do { nm' <- tNameN nm ; let fl' = cvtFlag fl - ; returnL $ UserTyVar noExtField fl' nm' } + ; returnLA $ UserTyVar noAnn fl' nm' } cvt_tv (TH.KindedTV nm fl ki) - = do { nm' <- tNameL nm + = do { nm' <- tNameN nm ; let fl' = cvtFlag fl ; ki' <- cvtKind ki - ; returnL $ KindedTyVar noExtField fl' nm' ki' } + ; returnLA $ KindedTyVar noAnn fl' nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1401,7 +1422,7 @@ cvtRole TH.InferR = Nothing cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs) cvtContext p tys = do { preds' <- mapM cvtPred tys - ; parenthesizeHsContext p <$> returnL preds' } + ; parenthesizeHsContext p <$> returnLA preds' } cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) cvtPred = cvtType @@ -1417,23 +1438,23 @@ cvtDerivClauseTys tys ; case tys' of [ty'@(L l (HsSig { sig_bndrs = HsOuterImplicit{} , sig_body = L _ (HsTyVar _ NotPromoted _) }))] - -> return $ L l $ DctSingle noExtField ty' - _ -> returnL $ DctMulti noExtField tys' } + -> return $ L (l2l l) $ DctSingle noExtField ty' + _ -> returnLA $ DctMulti noExtField tys' } cvtDerivClause :: TH.DerivClause -> CvtM (LHsDerivingClause GhcPs) cvtDerivClause (TH.DerivClause ds tys) = do { tys' <- cvtDerivClauseTys tys ; ds' <- traverse cvtDerivStrategy ds - ; returnL $ HsDerivingClause noExtField ds' tys' } + ; returnL $ HsDerivingClause noAnn ds' tys' } cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) -cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy -cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy -cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy +cvtDerivStrategy TH.StockStrategy = returnL (Hs.StockStrategy noAnn) +cvtDerivStrategy TH.AnyclassStrategy = returnL (Hs.AnyclassStrategy noAnn) +cvtDerivStrategy TH.NewtypeStrategy = returnL (Hs.NewtypeStrategy noAnn) cvtDerivStrategy (TH.ViaStrategy ty) = do ty' <- cvtSigType ty - returnL $ Hs.ViaStrategy ty' + returnL $ Hs.ViaStrategy (XViaStrategyPs noAnn ty') cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type" @@ -1460,18 +1481,20 @@ cvtTypeKind ty_str ty TupleT n | Just normals <- m_normals , normals `lengthIs` n -- Saturated - -> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals) + -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals) | otherwise -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) + (HsTyVar noAnn NotPromoted + (noLocA (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | Just normals <- m_normals , normals `lengthIs` n -- Saturated - -> returnL (HsTupleTy noExtField HsUnboxedTuple normals) + -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals) | otherwise -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) + (HsTyVar noAnn NotPromoted + (noLocA (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2 @@ -1481,56 +1504,56 @@ cvtTypeKind ty_str ty text "Sums must have an arity of at least 2" ] | Just normals <- m_normals , normals `lengthIs` n -- Saturated - -> returnL (HsSumTy noExtField normals) + -> returnLA (HsSumTy noAnn normals) | otherwise -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n)))) + (HsTyVar noAnn NotPromoted (noLocA (getRdrName (sumTyCon n)))) tys' ArrowT | Just normals <- m_normals , [x',y'] <- normals -> do x'' <- case unLoc x' of - HsFunTy{} -> returnL (HsParTy noExtField x') - HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646 - HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 + HsFunTy{} -> returnLA (HsParTy noAnn x') + HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646 + HsQualTy{} -> returnLA (HsParTy noAnn x') -- #15324 _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' - returnL (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x'' y'') + returnLA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x'' y'') | otherwise -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon))) + (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon))) tys' MulArrowT | Just normals <- m_normals , [w',x',y'] <- normals -> do x'' <- case unLoc x' of - HsFunTy{} -> returnL (HsParTy noExtField x') - HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646 - HsQualTy{} -> returnL (HsParTy noExtField x') -- #15324 + HsFunTy{} -> returnLA (HsParTy noAnn x') + HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646 + HsQualTy{} -> returnLA (HsParTy noAnn x') -- #15324 _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' w'' = hsTypeToArrow w' - returnL (HsFunTy noExtField w'' x'' y'') + returnLA (HsFunTy noAnn w'' x'' y'') | otherwise -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon))) + (HsTyVar noAnn NotPromoted (noLocA (getRdrName funTyCon))) tys' ListT | Just normals <- m_normals , [x'] <- normals -> - returnL (HsListTy noExtField x') + returnLA (HsListTy noAnn x') | otherwise -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon))) + (HsTyVar noAnn NotPromoted (noLocA (getRdrName listTyCon))) tys' - VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' } + VarT nm -> do { nm' <- tNameN nm + ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm ; let prom = name_promotedness nm' - ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'} + ; mk_apps (HsTyVar noAnn prom (noLocA nm')) tys'} ForallT tvs cxt ty | null tys' @@ -1538,9 +1561,10 @@ cvtTypeKind ty_str ty ; cxt' <- cvtContext funPrec cxt ; ty' <- cvtType ty ; loc <- getL - ; let tele = mkHsForAllInvisTele tvs' - hs_ty = mkHsForAllTy loc tele rho_ty - rho_ty = mkHsQualTy cxt loc cxt' ty' + ; let loc' = noAnnSrcSpan loc + ; let tele = mkHsForAllInvisTele noAnn tvs' + hs_ty = mkHsForAllTy loc' tele rho_ty + rho_ty = mkHsQualTy cxt loc' cxt' ty' ; return hs_ty } @@ -1549,13 +1573,14 @@ cvtTypeKind ty_str ty -> do { tvs' <- cvtTvs tvs ; ty' <- cvtType ty ; loc <- getL - ; let tele = mkHsForAllVisTele tvs' - ; pure $ mkHsForAllTy loc tele ty' } + ; let loc' = noAnnSrcSpan loc + ; let tele = mkHsForAllVisTele noAnn tvs' + ; pure $ mkHsForAllTy loc' tele ty' } SigT ty ki -> do { ty' <- cvtType ty ; ki' <- cvtKind ki - ; mk_apps (HsKindSig noExtField ty' ki') tys' + ; mk_apps (HsKindSig noAnn ty' ki') tys' } LitT lit @@ -1570,7 +1595,7 @@ cvtTypeKind ty_str ty ; t2' <- cvtType t2 ; let prom = name_promotedness s' ; mk_apps - (HsTyVar noExtField prom (noLoc s')) + (HsTyVar noAnn prom (noLocA s')) ([HsValArg t1', HsValArg t2'] ++ tys') } @@ -1582,44 +1607,48 @@ cvtTypeKind ty_str ty ParensT t -> do { t' <- cvtType t - ; mk_apps (HsParTy noExtField t') tys' + ; mk_apps (HsParTy noAnn t') tys' } PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm')) + ; mk_apps (HsTyVar noAnn IsPromoted + (noLocA nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n | Just normals <- m_normals , normals `lengthIs` n -- Saturated - -> returnL (HsExplicitTupleTy noExtField normals) + -> returnLA (HsExplicitTupleTy noAnn normals) | otherwise -> mk_apps - (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n)))) + (HsTyVar noAnn IsPromoted + (noLocA (getRdrName (tupleDataCon Boxed n)))) tys' PromotedNilT - -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys' + -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys' PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax | Just normals <- m_normals , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals - -> returnL (HsExplicitListTy noExtField ip (ty1:tys2)) + -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2)) | otherwise -> mk_apps - (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon))) + (HsTyVar noAnn IsPromoted (noLocA (getRdrName consDataCon))) tys' StarT -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) + (HsTyVar noAnn NotPromoted + (noLocA (getRdrName liftedTypeKindTyCon))) tys' ConstraintT -> mk_apps - (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon))) + (HsTyVar noAnn NotPromoted + (noLocA (getRdrName constraintKindTyCon))) tys' EqualityT @@ -1627,18 +1656,18 @@ cvtTypeKind ty_str ty , [x',y'] <- normals -> let px = parenthesizeHsType opPrec x' py = parenthesizeHsType opPrec y' - in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py) + in returnLA (HsOpTy noExtField px (noLocA eqTyCon_RDR) py) -- The long-term goal is to remove the above case entirely and -- subsume it under the case for InfixT. See #15815, comment:6, -- for more details. | otherwise -> - mk_apps (HsTyVar noExtField NotPromoted - (noLoc eqTyCon_RDR)) tys' + mk_apps (HsTyVar noAnn NotPromoted + (noLocA eqTyCon_RDR)) tys' ImplicitParamT n t -> do { n' <- wrapL $ ipName n ; t' <- cvtType t - ; returnL (HsIParamTy noExtField n' t') + ; returnLA (HsIParamTy noAnn n' t') } _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) @@ -1647,9 +1676,9 @@ cvtTypeKind ty_str ty hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs hsTypeToArrow w = case unLoc w of HsTyVar _ _ (L _ (isExact_maybe -> Just n)) - | n == oneDataConName -> HsLinearArrow NormalSyntax + | n == oneDataConName -> HsLinearArrow NormalSyntax Nothing | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax - _ -> HsExplicitMult NormalSyntax w + _ -> HsExplicitMult NormalSyntax Nothing w -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only @@ -1664,7 +1693,7 @@ name_promotedness nm -- | Constructs an application of a type to arguments passed in a list. mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) mk_apps head_ty type_args = do - head_ty' <- returnL head_ty + head_ty' <- returnLA head_ty -- We must parenthesize the function type in case of an explicit -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there -- _must_ be parentheses around `Maybe :: Type -> Type`. @@ -1679,13 +1708,13 @@ mk_apps head_ty type_args = do mk_apps (HsAppTy noExtField phead_ty p_ty) args HsTypeArg l ki -> do p_ki <- add_parens ki mk_apps (HsAppKindTy l phead_ty p_ki) args - HsArgPar _ -> mk_apps (HsParTy noExtField phead_ty) args + HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args go type_args where -- See Note [Adding parens for splices] add_parens lt@(L _ t) - | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt) + | hsTypeNeedsParens appPrec t = returnLA (HsParTy noAnn lt) | otherwise = return lt wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs @@ -1742,9 +1771,9 @@ cvtOpAppT (UInfixT x op2 y) op1 z = do { l <- cvtOpAppT y op1 z ; cvtOpAppT x op2 l } cvtOpAppT x op y - = do { op' <- tconNameL op + = do { op' <- tconNameN op ; x' <- cvtType x - ; returnL (mkHsOpTy x' op' y) } + ; returnLA (mkHsOpTy x' op' y) } cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" @@ -1774,9 +1803,9 @@ cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr cvtInjectivityAnnotation :: TH.InjectivityAnn -> CvtM (Hs.LInjectivityAnn GhcPs) cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) - = do { annLHS' <- tNameL annLHS - ; annRHS' <- mapM tNameL annRHS - ; returnL (Hs.InjectivityAnn annLHS' annRHS') } + = do { annLHS' <- tNameN annLHS + ; annRHS' <- mapM tNameN annRHS + ; returnL (Hs.InjectivityAnn noAnn annLHS' annRHS') } cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat @@ -1784,20 +1813,22 @@ cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- see Note [Pattern synonym type signatures and Template Haskell] cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null exis, null provs = cvtSigType (ForallT univs reqs ty) - | null univs, null reqs = do { l <- getL + | null univs, null reqs = do { l' <- getL + ; let l = noAnnSrcSpan l' ; ty' <- cvtType (ForallT exis provs ty) ; return $ L l $ mkHsImplicitSigType $ L l (HsQualTy { hst_ctxt = Nothing , hst_xqual = noExtField , hst_body = ty' }) } - | null reqs = do { l <- getL + | null reqs = do { l' <- getL + ; let l'' = noAnnSrcSpan l' ; univs' <- cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) - ; let forTy = mkHsExplicitSigType univs' $ L l cxtTy + ; let forTy = mkHsExplicitSigType noAnn univs' $ L l'' cxtTy cxtTy = HsQualTy { hst_ctxt = Nothing , hst_xqual = noExtField , hst_body = ty' } - ; return $ L l forTy } + ; return $ L (noAnnSrcSpan l') forTy } | otherwise = cvtSigType (ForallT univs reqs (ForallT exis provs ty)) cvtPatSynSigTy ty = cvtSigType ty @@ -1840,7 +1871,7 @@ unboxedSumChecks alt arity -- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' -- using the provided 'LHsQTyVars' and 'LHsType'. -mkHsForAllTy :: SrcSpan +mkHsForAllTy :: SrcSpanAnnA -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall -> HsForAllTelescope GhcPs @@ -1868,7 +1899,7 @@ mkHsForAllTy loc tele rho_ty -- they're empty. See #13183. mkHsQualTy :: TH.Cxt -- ^ The original Template Haskell context - -> SrcSpan + -> SrcSpanAnnA -- ^ The location of the returned 'LHsType' if it needs an -- explicit context -> LHsContext GhcPs @@ -1884,34 +1915,36 @@ mkHsQualTy ctxt loc ctxt' ty , hst_body = ty } mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs -mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit mkHsOuterExplicit +mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn) -------------------------------------------------------------------- -- Turning Name back into RdrName -------------------------------------------------------------------- -- variable names -vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +vNameN, cNameN, vcNameN, tNameN, tconNameN :: TH.Name -> CvtM (LocatedN RdrName) +vNameL :: TH.Name -> CvtM (LocatedA RdrName) vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName -- Variable names -vNameL n = wrapL (vName n) +vNameN n = wrapLN (vName n) +vNameL n = wrapLA (vName n) vName n = cvtName OccName.varName n -- Constructor function names; this is Haskell source, hence srcDataName -cNameL n = wrapL (cName n) +cNameN n = wrapLN (cName n) cName n = cvtName OccName.dataName n -- Variable *or* constructor names; check by looking at the first char -vcNameL n = wrapL (vcName n) +vcNameN n = wrapLN (vcName n) vcName n = if isVarName n then vName n else cName n -- Type variable names -tNameL n = wrapL (tName n) +tNameN n = wrapLN (tName n) tName n = cvtName OccName.tvName n -- Type Constructor names -tconNameL n = wrapL (tconName n) +tconNameN n = wrapLN (tconName n) tconName n = cvtName OccName.tcClsName n ipName :: String -> CvtM HsIPName diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index f89185ee24..c1947fab17 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -466,6 +466,7 @@ pprRuleName rn = doubleQuotes (ftext rn) data TopLevelFlag = TopLevel | NotTopLevel + deriving Data isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs index 3cce33a803..720b64433c 100644 --- a/compiler/GHC/Types/SourceText.hs +++ b/compiler/GHC/Types/SourceText.hs @@ -37,6 +37,7 @@ import GHC.Utils.Panic import Data.Function (on) import Data.Data import GHC.Real ( Ratio(..) ) +import GHC.Types.SrcLoc {- Note [Pragma source text] @@ -291,21 +292,31 @@ instance Outputable FractionalLit where data StringLiteral = StringLiteral { sl_st :: SourceText, -- literal raw source. -- See not [Literal source text] - sl_fs :: FastString -- literal string value + sl_fs :: FastString, -- literal string value + sl_tc :: Maybe RealSrcSpan -- Location of + -- possible + -- trailing comma + -- AZ: if we could have a LocatedA + -- StringLiteral we would not need sl_tc, but + -- that would cause import loops. + + -- AZ:2: sl_tc should be an AnnAnchor, to allow + -- editing and reprinting the AST. Need a more + -- robust solution. + } deriving Data instance Eq StringLiteral where - (StringLiteral _ a) == (StringLiteral _ b) = a == b + (StringLiteral _ a _) == (StringLiteral _ b _) = a == b instance Outputable StringLiteral where ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) instance Binary StringLiteral where - put_ bh (StringLiteral st fs) = do + put_ bh (StringLiteral st fs _) = do put_ bh st put_ bh fs get bh = do st <- get bh fs <- get bh - return (StringLiteral st fs) - + return (StringLiteral st fs Nothing) diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index a925b0a999..791e61375a 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -1037,6 +1037,182 @@ instance Binary Fingerprint where put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) +-- instance Binary FunctionOrData where +-- put_ bh IsFunction = putByte bh 0 +-- put_ bh IsData = putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> return IsFunction +-- 1 -> return IsData +-- _ -> panic "Binary FunctionOrData" + +-- instance Binary TupleSort where +-- put_ bh BoxedTuple = putByte bh 0 +-- put_ bh UnboxedTuple = putByte bh 1 +-- put_ bh ConstraintTuple = putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return BoxedTuple +-- 1 -> do return UnboxedTuple +-- _ -> do return ConstraintTuple + +-- instance Binary Activation where +-- put_ bh NeverActive = do +-- putByte bh 0 +-- put_ bh FinalActive = do +-- putByte bh 1 +-- put_ bh AlwaysActive = do +-- putByte bh 2 +-- put_ bh (ActiveBefore src aa) = do +-- putByte bh 3 +-- put_ bh src +-- put_ bh aa +-- put_ bh (ActiveAfter src ab) = do +-- putByte bh 4 +-- put_ bh src +-- put_ bh ab +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return NeverActive +-- 1 -> do return FinalActive +-- 2 -> do return AlwaysActive +-- 3 -> do src <- get bh +-- aa <- get bh +-- return (ActiveBefore src aa) +-- _ -> do src <- get bh +-- ab <- get bh +-- return (ActiveAfter src ab) + +-- instance Binary InlinePragma where +-- put_ bh (InlinePragma s a b c d) = do +-- put_ bh s +-- put_ bh a +-- put_ bh b +-- put_ bh c +-- put_ bh d + +-- get bh = do +-- s <- get bh +-- a <- get bh +-- b <- get bh +-- c <- get bh +-- d <- get bh +-- return (InlinePragma s a b c d) + +-- instance Binary RuleMatchInfo where +-- put_ bh FunLike = putByte bh 0 +-- put_ bh ConLike = putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- if h == 1 then return ConLike +-- else return FunLike + +-- instance Binary InlineSpec where +-- put_ bh NoUserInlinePrag = putByte bh 0 +-- put_ bh Inline = putByte bh 1 +-- put_ bh Inlinable = putByte bh 2 +-- put_ bh NoInline = putByte bh 3 + +-- get bh = do h <- getByte bh +-- case h of +-- 0 -> return NoUserInlinePrag +-- 1 -> return Inline +-- 2 -> return Inlinable +-- _ -> return NoInline + +-- instance Binary RecFlag where +-- put_ bh Recursive = do +-- putByte bh 0 +-- put_ bh NonRecursive = do +-- putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return Recursive +-- _ -> do return NonRecursive + +-- instance Binary OverlapMode where +-- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s +-- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s +-- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s +-- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s +-- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> (get bh) >>= \s -> return $ NoOverlap s +-- 1 -> (get bh) >>= \s -> return $ Overlaps s +-- 2 -> (get bh) >>= \s -> return $ Incoherent s +-- 3 -> (get bh) >>= \s -> return $ Overlapping s +-- 4 -> (get bh) >>= \s -> return $ Overlappable s +-- _ -> panic ("get OverlapMode" ++ show h) + + +-- instance Binary OverlapFlag where +-- put_ bh flag = do put_ bh (overlapMode flag) +-- put_ bh (isSafeOverlap flag) +-- get bh = do +-- h <- get bh +-- b <- get bh +-- return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +-- instance Binary FixityDirection where +-- put_ bh InfixL = do +-- putByte bh 0 +-- put_ bh InfixR = do +-- putByte bh 1 +-- put_ bh InfixN = do +-- putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return InfixL +-- 1 -> do return InfixR +-- _ -> do return InfixN + +-- instance Binary Fixity where +-- put_ bh (Fixity src aa ab) = do +-- put_ bh src +-- put_ bh aa +-- put_ bh ab +-- get bh = do +-- src <- get bh +-- aa <- get bh +-- ab <- get bh +-- return (Fixity src aa ab) + +-- instance Binary WarningTxt where +-- put_ bh (WarningTxt s w) = do +-- putByte bh 0 +-- put_ bh s +-- put_ bh w +-- put_ bh (DeprecatedTxt s d) = do +-- putByte bh 1 +-- put_ bh s +-- put_ bh d + +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do s <- get bh +-- w <- get bh +-- return (WarningTxt s w) +-- _ -> do s <- get bh +-- d <- get bh +-- return (DeprecatedTxt s d) + +-- instance Binary StringLiteral where +-- put_ bh (StringLiteral st fs _) = do +-- put_ bh st +-- put_ bh fs +-- get bh = do +-- st <- get bh +-- fs <- get bh +-- return (StringLiteral st fs Nothing) + instance Binary a => Binary (Located a) where put_ bh (L l x) = do put_ bh l diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index d26365ad77..5fe2d20d6b 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -24,7 +24,7 @@ module GHC.Utils.Outputable ( -- * Pretty printing combinators SDoc, runSDoc, PDoc(..), docToSDoc, - interppSP, interpp'SP, + interppSP, interpp'SP, interpp'SP', pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, empty, isEmpty, nest, @@ -1254,7 +1254,10 @@ interppSP xs = sep (map ppr xs) -- | Returns the comma-separated concatenation of the pretty printed things. interpp'SP :: Outputable a => [a] -> SDoc -interpp'SP xs = sep (punctuate comma (map ppr xs)) +interpp'SP xs = interpp'SP' ppr xs + +interpp'SP' :: (a -> SDoc) -> [a] -> SDoc +interpp'SP' f xs = sep (punctuate comma (map f xs)) -- | Returns the comma-separated concatenation of the quoted pretty printed things. -- diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index 0df44e8016..81369c3b09 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE ViewPatterns #-} {- (c) The University of Glasgow 2006 @@ -27,7 +28,7 @@ -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module Language.Haskell.Syntax.Decls ( -- * Toplevel declarations - HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, NewOrData(..), newOrDataToFlavour, StandaloneKindSig(..), LStandaloneKindSig, @@ -108,7 +109,6 @@ import GHC.Types.Name.Set import GHC.Types.Fixity -- others: -import GHC.Core.Class import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Types.SrcLoc @@ -229,7 +229,7 @@ data HsGroup p hs_annds :: [LAnnDecl p], hs_ruleds :: [LRuleDecls p], - hs_docs :: [LDocDecl] + hs_docs :: [LDocDecl p] } | XHsGroup !(XXHsGroup p) @@ -445,7 +445,7 @@ data TyClDecl pass tcdMeths :: LHsBinds pass, -- ^ Default methods tcdATs :: [LFamilyDecl pass], -- ^ Associated types; tcdATDefs :: [LTyFamDefltDecl pass], -- ^ Associated type defaults - tcdDocs :: [LDocDecl] -- ^ Haddock docs + tcdDocs :: [LDocDecl pass] -- ^ Haddock docs } -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass', -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen', @@ -457,7 +457,13 @@ data TyClDecl pass -- For details on above see note [Api annotations] in GHC.Parser.Annotation | XTyClDecl !(XXTyClDecl pass) -type LHsFunDep pass = XRec pass (FunDep (LIdP pass)) +data FunDep pass + = FunDep (XCFunDep pass) + [LIdP pass] + [LIdP pass] + | XFunDep !(XXFunDep pass) + +type LHsFunDep pass = XRec pass (FunDep pass) data DataDeclRn = DataDeclRn { tcdDataCusk :: Bool -- ^ does this have a CUSK? @@ -818,6 +824,7 @@ type LFamilyDecl pass = XRec pass (FamilyDecl pass) data FamilyDecl pass = FamilyDecl { fdExt :: XCFamilyDecl pass , fdInfo :: FamilyInfo pass -- type/data, closed/open + , fdTopLevel :: TopLevelFlag -- used for printing only , fdLName :: LIdP pass -- type constructor , fdTyVars :: LHsQTyVars pass -- type variables -- See Note [TyVar binders for associated declarations] @@ -848,11 +855,13 @@ type LInjectivityAnn pass = XRec pass (InjectivityAnn pass) -- -- This will be represented as "InjectivityAnn `r` [`a`, `c`]" data InjectivityAnn pass - = InjectivityAnn (LIdP pass) [LIdP pass] + = InjectivityAnn (XCInjectivityAnn pass) + (LIdP pass) [LIdP pass] -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : -- 'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar' -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XInjectivityAnn !(XXInjectivityAnn pass) data FamilyInfo pass = DataFamily @@ -916,7 +925,7 @@ data HsDataDefn pass -- The payload of a data type defn | XHsDataDefn !(XXHsDataDefn pass) -- | Haskell Deriving clause -type HsDeriving pass = XRec pass [LHsDerivingClause pass] +type HsDeriving pass = [LHsDerivingClause pass] -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is -- plural because one can specify multiple deriving clauses using the -- @-XDerivingStrategies@ language extension. @@ -1063,7 +1072,7 @@ data ConDecl pass { con_ext :: XConDeclH98 pass , con_name :: LIdP pass - , con_forall :: XRec pass Bool + , con_forall :: Bool -- ^ True <=> explicit user-written forall -- e.g. data T a = forall b. MkT b (b->a) -- con_ex_tvs = {b} @@ -1302,12 +1311,15 @@ type LTyFamDefltDecl pass = XRec pass (TyFamDefltDecl pass) type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass) -- | Type Family Instance Declaration -newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } +data TyFamInstDecl pass + = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl pass + , tfid_eqn :: TyFamInstEqn pass } -- ^ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', -- 'GHC.Parser.Annotation.AnnInstance', -- For details on above see note [Api annotations] in GHC.Parser.Annotation + | XTyFamInstDecl !(XXTyFamInstDecl pass) ----------------- Data family instances ------------- @@ -1448,13 +1460,14 @@ type LDerivStrategy pass = XRec pass (DerivStrategy pass) -- | Which technique the user explicitly requested when deriving an instance. data DerivStrategy pass -- See Note [Deriving strategies] in GHC.Tc.Deriv - = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a + = StockStrategy (XStockStrategy pass) + -- ^ GHC's \"standard\" strategy, which is to implement a -- custom instance for the data type. This only works -- for certain types that GHC knows about (e.g., 'Eq', -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, -- etc.) - | AnyclassStrategy -- ^ @-XDeriveAnyClass@ - | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | AnyclassStrategy (XAnyClassStrategy pass) -- ^ @-XDeriveAnyClass@ + | NewtypeStrategy (XNewtypeStrategy pass) -- ^ @-XGeneralizedNewtypeDeriving@ | ViaStrategy (XViaStrategy pass) -- ^ @-XDerivingVia@ @@ -1462,10 +1475,10 @@ data DerivStrategy pass derivStrategyName :: DerivStrategy a -> SDoc derivStrategyName = text . go where - go StockStrategy = "stock" - go AnyclassStrategy = "anyclass" - go NewtypeStrategy = "newtype" - go (ViaStrategy {}) = "via" + go StockStrategy {} = "stock" + go AnyclassStrategy {} = "anyclass" + go NewtypeStrategy {} = "newtype" + go ViaStrategy {} = "via" {- ************************************************************************ @@ -1693,7 +1706,7 @@ pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -} -- | Located Documentation comment Declaration -type LDocDecl = Located (DocDecl) +type LDocDecl pass = XRec pass (DocDecl) -- | Documentation comment Declaration data DocDecl @@ -1756,7 +1769,7 @@ type LAnnDecl pass = XRec pass (AnnDecl pass) data AnnDecl pass = HsAnnotation (XHsAnnotation pass) SourceText -- Note [Pragma source text] in GHC.Types.SourceText - (AnnProvenance (IdP pass)) (XRec pass (HsExpr pass)) + (AnnProvenance pass) (XRec pass (HsExpr pass)) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', -- 'GHC.Parser.Annotation.AnnType' -- 'GHC.Parser.Annotation.AnnModule' @@ -1766,18 +1779,18 @@ data AnnDecl pass = HsAnnotation | XAnnDecl !(XXAnnDecl pass) -- | Annotation Provenance -data AnnProvenance name = ValueAnnProvenance (Located name) - | TypeAnnProvenance (Located name) +data AnnProvenance pass = ValueAnnProvenance (LIdP pass) + | TypeAnnProvenance (LIdP pass) | ModuleAnnProvenance -deriving instance Functor AnnProvenance -deriving instance Foldable AnnProvenance -deriving instance Traversable AnnProvenance -deriving instance (Data pass) => Data (AnnProvenance pass) - -annProvenanceName_maybe :: AnnProvenance name -> Maybe name -annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name -annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name -annProvenanceName_maybe ModuleAnnProvenance = Nothing +-- deriving instance Functor AnnProvenance +-- deriving instance Foldable AnnProvenance +-- deriving instance Traversable AnnProvenance +-- deriving instance (Data pass) => Data (AnnProvenance pass) + +annProvenanceName_maybe :: forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p) +annProvenanceName_maybe (ValueAnnProvenance (unXRec @p -> name)) = Just name +annProvenanceName_maybe (TypeAnnProvenance (unXRec @p -> name)) = Just name +annProvenanceName_maybe ModuleAnnProvenance = Nothing {- ************************************************************************ diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 9967a78314..cb84d25489 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -143,26 +143,37 @@ values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess'). -- | RecordDotSyntax field updates -newtype FieldLabelStrings = - FieldLabelStrings [Located FieldLabelString] - deriving (Data) +newtype FieldLabelStrings p = + FieldLabelStrings [Located (HsFieldLabel p)] -instance Outputable FieldLabelStrings where +instance Outputable (FieldLabelStrings p) where ppr (FieldLabelStrings flds) = hcat (punctuate dot (map (ppr . unLoc) flds)) +instance OutputableBndr (FieldLabelStrings p) where + pprInfixOcc = pprFieldLabelStrings + pprPrefixOcc = pprFieldLabelStrings + +pprFieldLabelStrings :: FieldLabelStrings p -> SDoc +pprFieldLabelStrings (FieldLabelStrings flds) = + hcat (punctuate dot (map (ppr . unLoc) flds)) + +instance Outputable (HsFieldLabel p) where + ppr (HsFieldLabel _ s) = ppr s + ppr XHsFieldLabel{} = text "XHsFieldLabel" + -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates]. -type RecProj arg = HsRecField' FieldLabelStrings arg +type RecProj p arg = HsRecField' (FieldLabelStrings p) arg -- The phantom type parameter @p@ is for symmetry with @LHsRecField p -- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process). -type LHsRecProj p arg = Located (RecProj arg) +type LHsRecProj p arg = XRec p (RecProj p arg) -- These two synonyms are used in the definition of syntax @RecordUpd@ -- below. -type RecUpdProj p = RecProj (LHsExpr p) -type LHsRecUpdProj p = Located (RecUpdProj p) +type RecUpdProj p = RecProj p (LHsExpr p) +type LHsRecUpdProj p = XRec p (RecUpdProj p) {- ************************************************************************ @@ -366,7 +377,7 @@ data HsExpr p -- Note [ExplicitTuple] | ExplicitTuple (XExplicitTuple p) - [LHsTupArg p] + [HsTupArg p] Boxity -- | Used for unboxed sum types @@ -419,7 +430,7 @@ data HsExpr p -- For details on above see note [Api annotations] in GHC.Parser.Annotation | HsLet (XLet p) - (LHsLocalBinds p) + (HsLocalBinds p) (LHsExpr p) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', @@ -483,7 +494,7 @@ data HsExpr p | HsGetField { gf_ext :: XGetField p , gf_expr :: LHsExpr p - , gf_field :: Located FieldLabelString + , gf_field :: Located (HsFieldLabel p) } -- | Record field selector. e.g. @(.x)@ or @(.x.y)@ @@ -496,7 +507,7 @@ data HsExpr p | HsProjection { proj_ext :: XProjection p - , proj_flds :: [Located FieldLabelString] + , proj_flds :: [Located (HsFieldLabel p)] } -- | Expression with an explicit type signature. @e :: type@ @@ -611,6 +622,15 @@ type family PendingTcSplice' p -- --------------------------------------------------------------------- +data HsFieldLabel p + = HsFieldLabel + { hflExt :: XCHsFieldLabel p + , hflLabel :: Located FieldLabelString + } + | XHsFieldLabel !(XXHsFieldLabel p) + +-- --------------------------------------------------------------------- + -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p) @@ -790,7 +810,7 @@ See also #13680, which requested [] @Int to work. ----------------------- pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) +pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) = ppr (src,(n1,n2),(n3,n4)) {- @@ -897,7 +917,7 @@ data HsCmd id -- For details on above see note [Api annotations] in GHC.Parser.Annotation | HsCmdLet (XCmdLet id) - (LHsLocalBinds id) -- let(rec) + (HsLocalBinds id) -- let(rec) (LHsCmd id) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, @@ -1057,8 +1077,8 @@ isInfixMatch match = case m_ctxt match of data GRHSs p body = GRHSs { grhssExt :: XCGRHSs p body, - grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs - grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause + grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs + grhssLocalBinds :: HsLocalBinds p -- ^ The where clause } | XGRHSs !(XXGRHSs p body) @@ -1175,7 +1195,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@, -- For details on above see note [Api annotations] in GHC.Parser.Annotation - | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) + | LetStmt (XLetStmt idL idR body) (HsLocalBindsLR idL idR) -- ParStmts only occur in a list/monad comprehension | ParStmt (XParStmt idL idR body) -- Post typecheck, @@ -1215,7 +1235,8 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- For details on above see note [Api annotations] in GHC.Parser.Annotation | RecStmt { recS_ext :: XRecStmt idL idR body - , recS_stmts :: [LStmtLR idL idR body] + , recS_stmts :: XRec idR [LStmtLR idL idR body] + -- Assume XRec is the same for idL and idR, pick one arbitrarily -- The next two fields are only valid after renaming , recS_later_ids :: [IdP idR] @@ -1562,7 +1583,8 @@ data HsBracket p | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer | TypBr (XTypBr p) (LHsType p) -- [t| type |] - | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T + | VarBr (XVarBr p) Bool (LIdP p) + -- True: 'x, False: ''T -- (The Bool flag is used only in pprHsBracket) | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] | XBracket !(XXBracket p) -- Note [Trees that Grow] extension point diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index f843bee1a2..cd9804b7f9 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -10,7 +10,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension @@ -105,6 +104,8 @@ noExtCon x = case x of {} -- See Note [XRec and SrcSpans in the AST] type family XRec p a = r | r -> a +type family Anno a = b -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation + {- Note [XRec and SrcSpans in the AST] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -134,13 +135,16 @@ class UnXRec p where -- | We can map over the underlying type contained in an @XRec@ while preserving -- the annotation as is. --- See Note [XRec and SrcSpans in the AST] class MapXRec p where - mapXRec :: (a -> b) -> XRec p a -> XRec p b + mapXRec :: (Anno a ~ Anno b) => (a -> b) -> XRec p a -> XRec p b +-- See Note [XRec and SrcSpans in the AST] +-- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation +-- AZ: Is there a way to not have Anno in this file, but still have MapXRec? +-- Perhaps define XRec with an additional b parameter, only used in Hs as (Anno b)? -- | The trivial wrapper that carries no additional information -- See Note [XRec and SrcSpans in the AST] -class WrapXRec p where +class WrapXRec p a where wrapXRec :: a -> XRec p a -- | Maps the "normal" id type for a given pass @@ -246,6 +250,11 @@ type family XClassDecl x type family XXTyClDecl x -- ------------------------------------- +-- FunDep type families +type family XCFunDep x +type family XXFunDep x + +-- ------------------------------------- -- TyClGroup type families type family XCTyClGroup x type family XXTyClGroup x @@ -290,6 +299,11 @@ type family XCFamEqn x r type family XXFamEqn x r -- ------------------------------------- +-- TyFamInstDecl type families +type family XCTyFamInstDecl x +type family XXTyFamInstDecl x + +-- ------------------------------------- -- ClsInstDecl type families type family XCClsInstDecl x type family XXClsInstDecl x @@ -308,7 +322,10 @@ type family XXDerivDecl x -- ------------------------------------- -- DerivStrategy type family -type family XViaStrategy x +type family XStockStrategy x +type family XAnyClassStrategy x +type family XNewtypeStrategy x +type family XViaStrategy x -- ------------------------------------- -- DefaultDecl type families @@ -357,6 +374,11 @@ type family XXAnnDecl x type family XCRoleAnnotDecl x type family XXRoleAnnotDecl x +-- ------------------------------------- +-- InjectivityAnn type families +type family XCInjectivityAnn x +type family XXInjectivityAnn x + -- ===================================================================== -- Type families for the HsExpr extension points @@ -403,6 +425,11 @@ type family XPragE x type family XXExpr x -- ------------------------------------- +-- FieldLabel type families +type family XCHsFieldLabel x +type family XXHsFieldLabel x + +-- ------------------------------------- -- HsPragE type families type family XSCC x type family XXPragE x @@ -535,24 +562,25 @@ type family XXOverLit x -- ===================================================================== -- Type families for the HsPat extension points -type family XWildPat x -type family XVarPat x -type family XLazyPat x -type family XAsPat x -type family XParPat x -type family XBangPat x -type family XListPat x -type family XTuplePat x -type family XSumPat x -type family XConPat x -type family XViewPat x -type family XSplicePat x -type family XLitPat x -type family XNPat x -type family XNPlusKPat x -type family XSigPat x -type family XCoPat x -type family XXPat x +type family XWildPat x +type family XVarPat x +type family XLazyPat x +type family XAsPat x +type family XParPat x +type family XBangPat x +type family XListPat x +type family XTuplePat x +type family XSumPat x +type family XConPat x +type family XViewPat x +type family XSplicePat x +type family XLitPat x +type family XNPat x +type family XNPlusKPat x +type family XSigPat x +type family XCoPat x +type family XXPat x +type family XHsRecField x -- ===================================================================== -- Type families for the HsTypes type families diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index 8de0cc96d3..8c3309f477 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -45,7 +45,6 @@ import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Utils.Outputable import GHC.Types.SrcLoc -- libraries: -import Data.Data hiding (TyCon,Fixity) type LPat p = XRec p (Pat p) @@ -227,9 +226,9 @@ type family ConLikeP x -- | Haskell Constructor Pattern Details type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) -hsConPatArgs :: HsConPatDetails p -> [LPat p] +hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps -hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) +hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- | Haskell Record Fields @@ -241,7 +240,8 @@ data HsRecFields p arg -- A bunch of record fields -- Used for both expressions and patterns = HsRecFields { rec_flds :: [LHsRecField p arg], rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] - deriving (Functor, Foldable, Traversable) + -- AZ:The XRec for LHsRecField makes the derivings fail. + -- deriving (Functor, Foldable, Traversable) -- Note [DotDot fields] @@ -259,13 +259,13 @@ data HsRecFields p arg -- A bunch of record fields -- and the remainder being 'filled in' implicitly -- | Located Haskell Record Field -type LHsRecField' p arg = Located (HsRecField' p arg) +type LHsRecField' p id arg = XRec p (HsRecField' id arg) -- | Located Haskell Record Field -type LHsRecField p arg = Located (HsRecField p arg) +type LHsRecField p arg = XRec p (HsRecField p arg) -- | Located Haskell Record Update Field -type LHsRecUpdField p = Located (HsRecUpdField p) +type LHsRecUpdField p = XRec p (HsRecUpdField p) -- | Haskell Record Field type HsRecField p arg = HsRecField' (FieldOcc p) arg @@ -279,10 +279,11 @@ type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p) -- -- For details on above see note [Api annotations] in GHC.Parser.Annotation data HsRecField' id arg = HsRecField { + hsRecFieldAnn :: XHsRecField id, hsRecFieldLbl :: Located id, hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning hsRecPun :: Bool -- ^ Note [Punning] - } deriving (Data, Functor, Foldable, Traversable) + } deriving (Functor, Foldable, Traversable) -- Note [Punning] @@ -339,12 +340,12 @@ data HsRecField' id arg = HsRecField { -- -- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. -hsRecFields :: HsRecFields p arg -> [XCFieldOcc p] -hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) +hsRecFields :: forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p] +hsRecFields rbinds = map (unLoc . hsRecFieldSel . unXRec @p) (rec_flds rbinds) -- Probably won't typecheck at once, things have changed :/ -hsRecFieldsArgs :: HsRecFields p arg -> [arg] -hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) +hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg] +hsRecFieldsArgs rbinds = map (hsRecFieldArg . unXRec @p) (rec_flds rbinds) hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass) hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl @@ -358,7 +359,7 @@ hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (Outputable arg) +instance (Outputable arg, Outputable (XRec p (HsRecField p arg))) => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) @@ -367,8 +368,8 @@ instance (Outputable arg) where dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) -instance (Outputable p, Outputable arg) +instance (Outputable p, OutputableBndr p, Outputable arg) => Outputable (HsRecField' p arg) where - ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, + ppr (HsRecField { hsRecFieldLbl = L _ f, hsRecFieldArg = arg, hsRecPun = pun }) - = ppr f <+> (ppUnless pun $ equals <+> ppr arg) + = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index f0114403d8..6dc312859d 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -432,7 +432,7 @@ data HsPSRn = HsPSRn deriving Data -- | Located Haskell Signature Type -type LHsSigType pass = Located (HsSigType pass) -- Implicit only +type LHsSigType pass = XRec pass (HsSigType pass) -- Implicit only -- | Located Haskell Wildcard Type type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only @@ -893,7 +893,7 @@ data HsType pass -- For adding new constructors via Trees that Grow | XHsType - (XXType pass) + !(XXType pass) -- An escape hatch for tunnelling a Core 'Type' through 'HsType'. -- For more details on how this works, see: @@ -917,9 +917,9 @@ data HsTyLit data HsArrow pass = HsUnrestrictedArrow IsUnicodeSyntax -- ^ a -> b or a → b - | HsLinearArrow IsUnicodeSyntax + | HsLinearArrow IsUnicodeSyntax (Maybe AddApiAnn) -- ^ a %1 -> b or a %1 → b, or a ⊸ b - | HsExplicitMult IsUnicodeSyntax (LHsType pass) + | HsExplicitMult IsUnicodeSyntax (Maybe AddApiAnn) (LHsType pass) -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! -- This is how the programmer wrote it). It is stored as an -- `HsType` so as to preserve the syntax as written in the @@ -939,7 +939,7 @@ hsScaledThing (HsScaled _ t) = t -- the shorthands work trivially at each pass. hsUnrestricted, hsLinear :: a -> HsScaled pass a hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax) -hsLinear = HsScaled (HsLinearArrow NormalSyntax) +hsLinear = HsScaled (HsLinearArrow NormalSyntax Nothing) instance Outputable a => Outputable (HsScaled pass a) where ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t @@ -1258,7 +1258,7 @@ type LFieldOcc pass = XRec pass (FieldOcc pass) -- We store both the 'RdrName' the user originally wrote, and after the renamer, -- the selector function. data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass - , rdrNameFieldOcc :: Located RdrName + , rdrNameFieldOcc :: LocatedN RdrName -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr" } @@ -1270,6 +1270,13 @@ deriving instance (Eq (XCFieldOcc pass), Eq (XXFieldOcc pass)) => Eq (FieldOcc p instance Outputable (FieldOcc pass) where ppr = ppr . rdrNameFieldOcc +instance OutputableBndr (FieldOcc pass) where + pprInfixOcc = pprInfixOcc . unLoc . rdrNameFieldOcc + pprPrefixOcc = pprPrefixOcc . unLoc . rdrNameFieldOcc + +instance OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprPrefixOcc . unLoc -- | Ambiguous Field Occurrence -- @@ -1284,8 +1291,8 @@ instance Outputable (FieldOcc pass) where -- Note [Disambiguating record fields] in "GHC.Tc.Gen.Head". -- See Note [Located RdrNames] in "GHC.Hs.Expr" data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (Located RdrName) - | Ambiguous (XAmbiguous pass) (Located RdrName) + = Unambiguous (XUnambiguous pass) (LocatedN RdrName) + | Ambiguous (XAmbiguous pass) (LocatedN RdrName) | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass) |