diff options
369 files changed, 23718 insertions, 10092 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) @@ -567,8 +567,8 @@ ghc/stage2/package-data.mk: compiler/stage2/package-data.mk # the ghc library's package-data.mk is sufficient, as that in turn depends on # all the other libraries' package-data.mk files. utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk -utils/check-api-annotations/dist-install/package-data.mk: compiler/stage2/package-data.mk utils/check-ppr/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/check-exact/dist-install/package-data.mk: compiler/stage2/package-data.mk # add the final package.conf dependency: ghc-prim depends on RTS libraries/ghc-prim/dist-install/package-data.mk : rts/dist/package.conf.inplace @@ -665,8 +665,8 @@ BUILD_DIRS += compiler BUILD_DIRS += utils/hsc2hs BUILD_DIRS += utils/ghc-pkg BUILD_DIRS += utils/testremove -BUILD_DIRS += utils/check-api-annotations BUILD_DIRS += utils/check-ppr +BUILD_DIRS += utils/check-exact BUILD_DIRS += utils/ghc-cabal BUILD_DIRS += utils/hpc BUILD_DIRS += utils/runghc @@ -707,8 +707,8 @@ endif ifneq "$(CrossCompiling) $(Stage1Only)" "NO NO" # See Note [No stage2 packages when CrossCompiling or Stage1Only]. # See Note [Stage1Only vs stage=1] in mk/config.mk.in. -BUILD_DIRS := $(filter-out utils/check-api-annotations,$(BUILD_DIRS)) BUILD_DIRS := $(filter-out utils/check-ppr,$(BUILD_DIRS)) +BUILD_DIRS := $(filter-out utils/check-exact,$(BUILD_DIRS)) endif endif # CLEANING diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index d4dbfc7c60..ea2c8f25bb 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -1272,8 +1272,8 @@ runStmt input step = do run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult) -- Only turn `FunBind` and `VarBind` into statements, other bindings -- (e.g. `PatBind`) need to stay as decls. - run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind) - run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind) + run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt (locA l) bind) + run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt (locA l) bind) -- Note that any `x = y` declarations below will be run as declarations -- instead of statements (e.g. `...; x = y; ...`) run_decls decls = do @@ -1290,9 +1290,9 @@ runStmt input step = do mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs mk_stmt loc bind = let - l :: a -> Located a - l = L loc - in l (LetStmt noExtField (l (HsValBinds noExtField (ValBinds noExtField (unitBag (l bind)) [])))) + la = L (noAnnSrcSpan loc) + la' = L (noAnnSrcSpan loc) + in la (LetStmt noAnn (HsValBinds noAnn (ValBinds NoAnnSortKey (unitBag (la' bind)) []))) setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500 setDumpFilePrefix ic = do @@ -1713,13 +1713,15 @@ defineMacro overwrite s = do step <- getGhciStepIO expr <- GHC.parseExpr definition -- > ghciStepIO . definition :: String -> IO String - let stringTy = nlHsTyVar stringTyCon_RDR + let stringTy :: LHsType GhcPs + stringTy = nlHsTyVar stringTyCon_RDR + ioM :: LHsType GhcPs -- AZ ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) `mkHsApp` (nlHsPar expr) - tySig = mkHsWildCardBndrs $ noLoc $ mkHsImplicitSigType $ + tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $ nlHsFunTy stringTy ioM - new_expr = L (getLoc expr) $ ExprWithTySig noExtField body tySig + new_expr = L (getLoc expr) $ ExprWithTySig noAnn body tySig hv <- GHC.compileParsedExprRemote new_expr let newCmd = Command { cmdName = macro_name @@ -1786,9 +1788,9 @@ getGhciStepIO = do ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar (getRdrName ghciStepIoMName) - tySig = mkHsWildCardBndrs $ noLoc $ mkHsImplicitSigType $ + tySig = mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType $ nlHsFunTy ghciM ioM - return $ noLoc $ ExprWithTySig noExtField body tySig + return $ noLocA $ ExprWithTySig noAnn body tySig ----------------------------------------------------------------------------- -- :check diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index e7b2234dfa..144ebc4a78 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -320,9 +320,9 @@ getModInfo name = do processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule -> m [SpanInfo] processAllTypeCheckedModule tcm = do - bts <- mapM getTypeLHsBind $ listifyAllSpans tcs - ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs - pts <- mapM getTypeLPat $ listifyAllSpans tcs + bts <- mapM (getTypeLHsBind ) $ listifyAllSpans tcs + ets <- mapM (getTypeLHsExpr ) $ listifyAllSpans tcs + pts <- mapM (getTypeLPat ) $ listifyAllSpans tcs return $ mapMaybe toSpanInfo $ sortBy cmpSpan $ catMaybes (bts ++ ets ++ pts) @@ -332,7 +332,7 @@ processAllTypeCheckedModule tcm = do -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) - = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid)) + = pure $ Just (Just (unLoc pid), getLocA pid,varType (unLoc pid)) getTypeLHsBind _ = pure Nothing -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's @@ -340,7 +340,7 @@ processAllTypeCheckedModule tcm = do getTypeLHsExpr e = do hs_env <- getSession (_,mbe) <- liftIO $ deSugarExpr hs_env e - return $ fmap (\expr -> (mid, getLoc e, GHC.Core.Utils.exprType expr)) mbe + return $ fmap (\expr -> (mid, getLocA e, GHC.Core.Utils.exprType expr)) mbe where mid :: Maybe Id mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i @@ -352,17 +352,17 @@ processAllTypeCheckedModule tcm = do -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLPat (L spn pat) = - pure (Just (getMaybeId pat,spn,hsPatType pat)) + pure (Just (getMaybeId pat,locA spn,hsPatType pat)) where getMaybeId :: Pat GhcTc -> Maybe Id getMaybeId (VarPat _ (L _ vid)) = Just vid getMaybeId _ = Nothing -- | Get ALL source spans in the source. - listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] + listifyAllSpans :: Typeable a => TypecheckedSource -> [LocatedA a] listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x])) where - p (L spn _) = isGoodSrcSpan spn + p (L spn _) = isGoodSrcSpan (locA spn) -- | Variant of @syb@'s @everything@ (which summarises all nodes -- in top-down, left-to-right order) with a stop-condition on 'NameSet's diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs index a1916b20cd..b107a6e512 100644 --- a/hadrian/src/Packages.hs +++ b/hadrian/src/Packages.hs @@ -1,7 +1,8 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Packages ( -- * GHC packages - array, base, binary, bytestring, cabal, checkApiAnnotations, checkPpr, + array, base, binary, bytestring, cabal, checkPpr, + checkExact, compareSizes, compiler, containers, deepseq, deriveConstants, directory, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, @@ -31,7 +32,7 @@ import Oracles.Setting -- packages and modify build default build conditions in "UserSettings". ghcPackages :: [Package] ghcPackages = - [ array, base, binary, bytestring, cabal, checkPpr, checkApiAnnotations + [ array, base, binary, bytestring, cabal, checkPpr , compareSizes, compiler, containers, deepseq, deriveConstants, directory , exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh , ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs @@ -50,8 +51,8 @@ base = lib "base" binary = lib "binary" bytestring = lib "bytestring" cabal = lib "Cabal" `setPath` "libraries/Cabal/Cabal" -checkApiAnnotations = util "check-api-annotations" checkPpr = util "check-ppr" +checkExact = util "check-exact" compareSizes = util "compareSizes" `setPath` "utils/compare_sizes" compiler = top "ghc" `setPath` "compiler" containers = lib "containers" `setPath` "libraries/containers/containers" diff --git a/hadrian/src/Rules/BinaryDist.hs b/hadrian/src/Rules/BinaryDist.hs index a527664b23..8a4fd2c4ec 100644 --- a/hadrian/src/Rules/BinaryDist.hs +++ b/hadrian/src/Rules/BinaryDist.hs @@ -171,8 +171,8 @@ bindistRules = do -- other machine. need $ map (bindistFilesDir -/-) (["configure", "Makefile"] ++ bindistInstallFiles) - need $ map ((bindistFilesDir -/- "wrappers") -/-) ["check-api-annotations" - , "check-ppr", "ghc", "ghc-iserv", "ghc-pkg" + need $ map ((bindistFilesDir -/- "wrappers") -/-) + [ "check-ppr", "check-exact", "ghc", "ghc-iserv", "ghc-pkg" , "ghci-script", "haddock", "hpc", "hp2ps", "hsc2hs" , "runghc"] diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs index b1e328368f..43982b9549 100644 --- a/hadrian/src/Rules/Test.hs +++ b/hadrian/src/Rules/Test.hs @@ -27,15 +27,20 @@ ghcConfigProgPath = "test/bin/ghc-config" <.> exe checkPprProgPath, checkPprSourcePath :: FilePath checkPprProgPath = "test/bin/check-ppr" <.> exe checkPprSourcePath = "utils/check-ppr/Main.hs" +checkPprExtra :: Maybe String +checkPprExtra = Nothing -checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath :: FilePath -checkApiAnnotationsProgPath = "test/bin/check-api-annotations" <.> exe -checkApiAnnotationsSourcePath = "utils/check-api-annotations/Main.hs" +checkExactProgPath, checkExactSourcePath :: FilePath +checkExactProgPath = "test/bin/check-exact" <.> exe +checkExactSourcePath = "utils/check-exact/Main.hs" +checkExactExtra :: Maybe String +checkExactExtra = Just "-iutils/check-exact" -checkPrograms :: [(FilePath, FilePath, Package)] + +checkPrograms :: [(FilePath, FilePath, Maybe String, Package)] checkPrograms = - [ (checkPprProgPath, checkPprSourcePath, checkPpr) - , (checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath, checkApiAnnotations) + [ (checkPprProgPath, checkPprSourcePath, checkPprExtra, checkPpr) + , (checkExactProgPath, checkExactSourcePath, checkExactExtra, checkExact) ] ghcConfigPath :: FilePath @@ -53,9 +58,10 @@ testRules = do -- Reasons why this is required are not entirely clear. cmd ["bash"] ["-c", ghc0Path ++ " " ++ ghcConfigHsPath ++ " -o " ++ (root -/- ghcConfigProgPath)] - -- Rules for building check-ppr and check-ppr-annotations with the compiler - -- we are going to test (in-tree or out-of-tree). - forM_ checkPrograms $ \(progPath, sourcePath, progPkg) -> + -- Rules for building check-ppr, check-exact and + -- check-ppr-annotations with the compiler we are going to test + -- (in-tree or out-of-tree). + forM_ checkPrograms $ \(progPath, sourcePath, mextra, progPkg) -> root -/- progPath %> \path -> do need [ sourcePath ] testGhc <- testCompiler <$> userSetting defaultTestArgs @@ -79,6 +85,7 @@ testRules = do cmd [bindir </> "ghc" <.> exe] $ concatMap (\p -> ["-package", pkgName p]) depsPkgs ++ ["-o", top -/- path, top -/- sourcePath] ++ + (maybe [] (\e -> [e]) mextra) ++ -- If GHC is build with debug options, then build check-ppr -- also with debug options. This allows, e.g., to print debug -- messages of various RTS subsystems while using check-ppr. @@ -125,7 +132,8 @@ testRules = do ] pythonPath <- builderPath Python - need [ root -/- checkPprProgPath, root -/- checkApiAnnotationsProgPath ] + need [ root -/- checkPprProgPath + , root -/- checkExactProgPath ] -- Set environment variables for test's Makefile. -- TODO: Ideally we would define all those env vars in 'env', so that @@ -141,8 +149,7 @@ testRules = do setEnv "TEST_HC_OPTS" ghcFlags setEnv "TEST_HC_OPTS_INTERACTIVE" ghciFlags setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath) - setEnv "CHECK_API_ANNOTATIONS" - (top -/- root -/- checkApiAnnotationsProgPath) + setEnv "CHECK_EXACT" (top -/- root -/- checkExactProgPath) -- This lets us bypass the need to generate a config -- through Make, which happens in testsuite/mk/boilerplate.mk diff --git a/hadrian/src/Settings/Builders/Make.hs b/hadrian/src/Settings/Builders/Make.hs index 12f01e7774..9efea20275 100644 --- a/hadrian/src/Settings/Builders/Make.hs +++ b/hadrian/src/Settings/Builders/Make.hs @@ -25,13 +25,13 @@ validateBuilderArgs = builder (Make "testsuite/tests") ? do top <- expr topDirectory compiler <- expr $ fullpath ghc checkPpr <- expr $ fullpath checkPpr - checkApiAnnotations <- expr $ fullpath checkApiAnnotations + checkExact <- expr $ fullpath checkExact args <- expr $ userSetting defaultTestArgs return [ setTestSpeed $ testSpeed args , "THREADS=" ++ show threads , "TEST_HC=" ++ (top -/- compiler) , "CHECK_PPR=" ++ (top -/- checkPpr) - , "CHECK_API_ANNOTATIONS=" ++ (top -/- checkApiAnnotations) + , "CHECK_EXACT=" ++ (top -/- checkExact) ] where fullpath :: Package -> Action FilePath diff --git a/testsuite/mk/boilerplate.mk b/testsuite/mk/boilerplate.mk index 6ccc43ed8d..41ba2542a6 100644 --- a/testsuite/mk/boilerplate.mk +++ b/testsuite/mk/boilerplate.mk @@ -219,14 +219,13 @@ CP = cp RM = rm -f PYTHON ?= python3 -ifeq "$(CHECK_API_ANNOTATIONS)" "" -CHECK_API_ANNOTATIONS := $(abspath $(TOP)/../inplace/bin/check-api-annotations) -endif - ifeq "$(CHECK_PPR)" "" CHECK_PPR := $(abspath $(TOP)/../inplace/bin/check-ppr) endif +ifeq "$(CHECK_EXACT)" "" +CHECK_EXACT := $(abspath $(TOP)/../inplace/bin/check-exact) +endif # ----------------------------------------------------------------------------- # configuration of TEST_HC diff --git a/testsuite/tests/annotations/should_fail/annfail01.stderr b/testsuite/tests/annotations/should_fail/annfail01.stderr index 44ac680a89..f3f5a75740 100644 --- a/testsuite/tests/annotations/should_fail/annfail01.stderr +++ b/testsuite/tests/annotations/should_fail/annfail01.stderr @@ -1,8 +1,8 @@ -annfail01.hs:4:1: +annfail01.hs:4:14: Not in scope: type constructor or class ‘Foo’ In the annotation: {-# ANN type Foo (1 :: Int) #-} -annfail01.hs:5:1: +annfail01.hs:5:9: Not in scope: ‘f’ In the annotation: {-# ANN f (1 :: Int) #-} diff --git a/testsuite/tests/annotations/should_fail/annfail02.stderr b/testsuite/tests/annotations/should_fail/annfail02.stderr index d52e52abdd..0b1e556739 100644 --- a/testsuite/tests/annotations/should_fail/annfail02.stderr +++ b/testsuite/tests/annotations/should_fail/annfail02.stderr @@ -1,8 +1,8 @@ -annfail02.hs:6:1: +annfail02.hs:6:9: Not in scope: data constructor ‘Foo’ In the annotation: {-# ANN Foo (1 :: Int) #-} -annfail02.hs:7:1: +annfail02.hs:7:14: Not in scope: type constructor or class ‘Bar’ In the annotation: {-# ANN type Bar (2 :: Int) #-} diff --git a/testsuite/tests/annotations/should_fail/annfail11.stderr b/testsuite/tests/annotations/should_fail/annfail11.stderr index 40bcebb904..a1c2e3fd24 100644 --- a/testsuite/tests/annotations/should_fail/annfail11.stderr +++ b/testsuite/tests/annotations/should_fail/annfail11.stderr @@ -1,12 +1,12 @@ -annfail11.hs:3:1: error: +annfail11.hs:3:9: error: Not in scope: ‘length’ Perhaps you want to add ‘length’ to the import list in the import of ‘Prelude’ (annfail11.hs:1:8-16). In the annotation: {-# ANN length "Cannot annotate other modules yet" #-} -annfail11.hs:4:1: error: +annfail11.hs:4:14: error: Not in scope: type constructor or class ‘Integer’ Perhaps you want to add ‘Integer’ to the import list in the import of ‘Prelude’ (annfail11.hs:1:8-16). diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr index c6454ccc30..d888ad8e90 100644 --- a/testsuite/tests/deriving/should_compile/T14682.stderr +++ b/testsuite/tests/deriving/should_compile/T14682.stderr @@ -33,23 +33,23 @@ Derived class instances: instance GHC.Classes.Ord T14682.Foo where GHC.Classes.compare a b - = case a of { + = case a of T14682.Foo a1 a2 - -> case b of { + -> case b of T14682.Foo b1 b2 -> case (GHC.Classes.compare a1 b1) of GHC.Types.LT -> GHC.Types.LT GHC.Types.EQ -> (a2 `GHC.Classes.compare` b2) - GHC.Types.GT -> GHC.Types.GT } } + GHC.Types.GT -> GHC.Types.GT (GHC.Classes.<) a b - = case a of { + = case a of T14682.Foo a1 a2 - -> case b of { + -> case b of T14682.Foo b1 b2 -> case (GHC.Classes.compare a1 b1) of GHC.Types.LT -> GHC.Types.True GHC.Types.EQ -> (a2 GHC.Classes.< b2) - GHC.Types.GT -> GHC.Types.False } } + GHC.Types.GT -> GHC.Types.False (GHC.Classes.<=) a b = GHC.Classes.not ((GHC.Classes.<) b a) (GHC.Classes.>) a b = (GHC.Classes.<) b a (GHC.Classes.>=) a b = GHC.Classes.not ((GHC.Classes.<) a b) diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr index 9d7cb859bd..cb0aca5e05 100644 --- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr +++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr @@ -7,7 +7,7 @@ Derived class instances: GHC.Read.readListPrec = GHC.Read.readListPrecDefault instance GHC.Show.Show (DrvEmptyData.Void a) where - GHC.Show.showsPrec _ z = case z of + GHC.Show.showsPrec _ z = case z of {} instance GHC.Classes.Ord (DrvEmptyData.Void a) where GHC.Classes.compare _ z = GHC.Types.EQ @@ -17,38 +17,38 @@ Derived class instances: instance Data.Data.Data a => Data.Data.Data (DrvEmptyData.Void a) where - Data.Data.gfoldl _ _ z = case z of - Data.Data.gunfold k z c = case Data.Data.constrIndex c of - Data.Data.toConstr z = case z of + Data.Data.gfoldl _ _ z = case z of {} + Data.Data.gunfold k z c = case Data.Data.constrIndex c of {} + Data.Data.toConstr z = case z of {} Data.Data.dataTypeOf _ = $tVoid Data.Data.dataCast1 f = Data.Typeable.gcast1 f instance GHC.Base.Functor DrvEmptyData.Void where - GHC.Base.fmap _ z = case z of - (GHC.Base.<$) _ z = case z of + GHC.Base.fmap _ z = case z of {} + (GHC.Base.<$) _ z = case z of {} instance Data.Foldable.Foldable DrvEmptyData.Void where Data.Foldable.foldMap _ z = GHC.Base.mempty instance Data.Traversable.Traversable DrvEmptyData.Void where - Data.Traversable.traverse _ z = GHC.Base.pure (case z of) + Data.Traversable.traverse _ z = GHC.Base.pure (case z of {}) instance GHC.Generics.Generic (DrvEmptyData.Void a) where GHC.Generics.from x - = GHC.Generics.M1 (case x of { x -> case x of }) - GHC.Generics.to (GHC.Generics.M1 x) = case x of { x -> case x of } + = GHC.Generics.M1 (case x of x -> case x of {}) + GHC.Generics.to (GHC.Generics.M1 x) = case x of x -> case x of {} instance GHC.Generics.Generic1 DrvEmptyData.Void where GHC.Generics.from1 x - = GHC.Generics.M1 (case x of { x -> case x of }) - GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { x -> case x of } + = GHC.Generics.M1 (case x of x -> case x of {}) + GHC.Generics.to1 (GHC.Generics.M1 x) = case x of x -> case x of {} instance Language.Haskell.TH.Syntax.Lift (DrvEmptyData.Void a) where - Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of) + Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of {}) Language.Haskell.TH.Syntax.liftTyped z = Language.Haskell.TH.Syntax.unsafeCodeCoerce - (GHC.Base.pure (case z of)) + (GHC.Base.pure (case z of {})) $tVoid :: Data.Data.DataType $tVoid = Data.Data.mkDataType "Void" [] diff --git a/testsuite/tests/gadt/T3169.stderr b/testsuite/tests/gadt/T3169.stderr index 5770e03c70..9ab61c8720 100644 --- a/testsuite/tests/gadt/T3169.stderr +++ b/testsuite/tests/gadt/T3169.stderr @@ -10,8 +10,8 @@ T3169.hs:13:22: error: • In the second argument of ‘lookup’, namely ‘m’ In the expression: lookup a m :: Maybe (Map b elt) In the expression: - case lookup a m :: Maybe (Map b elt) of { - Just (m2 :: Map b elt) -> lookup b m2 :: Maybe elt } + case lookup a m :: Maybe (Map b elt) of + Just (m2 :: Map b elt) -> lookup b m2 :: Maybe elt • Relevant bindings include m :: Map (a, b) elt (bound at T3169.hs:12:17) b :: b (bound at T3169.hs:12:13) diff --git a/testsuite/tests/gadt/gadt-escape1.stderr b/testsuite/tests/gadt/gadt-escape1.stderr index d771c63828..f2b7ac569e 100644 --- a/testsuite/tests/gadt/gadt-escape1.stderr +++ b/testsuite/tests/gadt/gadt-escape1.stderr @@ -14,6 +14,6 @@ gadt-escape1.hs:19:58: error: • In the expression: a In a case alternative: Hidden (ExpInt _) a -> a In the expression: - case (hval :: Hidden) of { Hidden (ExpInt _) a -> a } + case (hval :: Hidden) of Hidden (ExpInt _) a -> a • Relevant bindings include weird1 :: p (bound at gadt-escape1.hs:19:1) diff --git a/testsuite/tests/gadt/gadt7.stderr b/testsuite/tests/gadt/gadt7.stderr index 679ec3b00e..314404c246 100644 --- a/testsuite/tests/gadt/gadt7.stderr +++ b/testsuite/tests/gadt/gadt7.stderr @@ -14,7 +14,7 @@ gadt7.hs:16:38: error: Possible fix: add a type signature for ‘i1b’ • In the expression: y1 In a case alternative: K -> y1 - In the expression: case t1 of { K -> y1 } + In the expression: case t1 of K -> y1 • Relevant bindings include y1 :: p (bound at gadt7.hs:16:16) y :: p (bound at gadt7.hs:16:7) diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr index 99c5ee8088..933bbecdff 100644 --- a/testsuite/tests/generics/T10604/T10604_deriving.stderr +++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr @@ -93,52 +93,52 @@ Derived class instances: GHC.Generics.Generic (T10604_deriving.Wrap2 @k a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Wrap2 g1 - -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) }) + -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { + = case x of (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) - -> T10604_deriving.Wrap2 g1 } + -> T10604_deriving.Wrap2 g1 instance GHC.Generics.Generic1 @(k -> *) (T10604_deriving.Wrap2 @k) where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Wrap2 g1 -> GHC.Generics.M1 (GHC.Generics.M1 ((GHC.Base..) - GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g1)) }) + GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g1))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { + = case x of (GHC.Generics.M1 (GHC.Generics.M1 g1)) -> T10604_deriving.Wrap2 ((GHC.Base..) - (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g1) } + (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g1) instance GHC.Generics.Generic (T10604_deriving.Wrap a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Wrap g1 - -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) }) + -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { + = case x of (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) - -> T10604_deriving.Wrap g1 } + -> T10604_deriving.Wrap g1 instance GHC.Generics.Generic1 @(* -> *) T10604_deriving.Wrap where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Wrap g1 - -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.Rec1 g1)) }) + -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.Rec1 g1))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { + = case x of (GHC.Generics.M1 (GHC.Generics.M1 g1)) - -> T10604_deriving.Wrap (GHC.Generics.unRec1 g1) } + -> T10604_deriving.Wrap (GHC.Generics.unRec1 g1) instance GHC.Base.Functor (T10604_deriving.Proxy @(*)) where GHC.Base.fmap _ = GHC.Prim.coerce @@ -147,31 +147,31 @@ Derived class instances: GHC.Generics.Generic (T10604_deriving.Proxy @k a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { - T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 }) + (case x of + T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy } + = case x of + (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy instance GHC.Generics.Generic1 @k (T10604_deriving.Proxy @k) where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { - T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 }) + (case x of + T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy } + = case x of + (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy instance GHC.Generics.Generic (T10604_deriving.Empty a) where GHC.Generics.from x - = GHC.Generics.M1 (case x of { x -> case x of }) - GHC.Generics.to (GHC.Generics.M1 x) = case x of { x -> case x of } + = GHC.Generics.M1 (case x of x -> case x of {}) + GHC.Generics.to (GHC.Generics.M1 x) = case x of x -> case x of {} instance GHC.Generics.Generic1 @GHC.Types.Bool T10604_deriving.Empty where GHC.Generics.from1 x - = GHC.Generics.M1 (case x of { x -> case x of }) - GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { x -> case x of } + = GHC.Generics.M1 (case x of x -> case x of {}) + GHC.Generics.to1 (GHC.Generics.M1 x) = case x of x -> case x of {} Derived type family instances: diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 7c56320ff3..ae0bca225d 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -41,6 +41,6 @@ main = do | (MG _ (L _ (m:_)) _) <- fun_matches f, ((L _ (c@ConPat{})):_)<-hsLMatchPats m, (L l _)<-pat_con c - = isGoodSrcSpan l -- Check that the source location is a good one + = isGoodSrcSpan (locA l) -- Check that the source location is a good one isDataCon _ = False diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.stdout b/testsuite/tests/ghc-api/annotations-literals/literals.stdout index 501a5af5f3..eb87a80162 100644 --- a/testsuite/tests/ghc-api/annotations-literals/literals.stdout +++ b/testsuite/tests/ghc-api/annotations-literals/literals.stdout @@ -1,4 +1,4 @@ -(LiteralsTest.hs:1:1-26,ITblockComment "{-# LANGUAGE MagicHash #-}",[{-# LANGUAGE MagicHash #-}]), +(LiteralsTest.hs:1:1-26,ITblockComment "{-# LANGUAGE MagicHash #-}" (PsSpan {psRealSpan = SrcSpanPoint "./LiteralsTest.hs" 1 1, psBufSpan = BufSpan {bufSpanStart = BufPos {bufPos = 0}, bufSpanEnd = BufPos {bufPos = 0}}}),[{-# LANGUAGE MagicHash #-}]), (LiteralsTest.hs:2:1-6,ITmodule,[module]), diff --git a/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.hs b/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.hs new file mode 100644 index 0000000000..c454b0a237 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ViewPatterns, BangPatterns #-} +module InTreeAnnotations1 where + +foo a@(_,_) !"a" ~x = undefined + +data T = MkT { x,y :: Int } + +f (MkT { x = !v, y = negate -> w }) = v + w diff --git a/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.stderr b/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.stderr new file mode 100644 index 0000000000..42e3143635 --- /dev/null +++ b/testsuite/tests/ghc-api/annotations/InTreeAnnotations1.stderr @@ -0,0 +1,521 @@ + +==================== Parser AST ==================== + +(L + { InTreeAnnotations1.hs:1:1 } + (HsModule + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddApiAnn AnnModule (AR { InTreeAnnotations1.hs:2:1-6 })) + ,(AddApiAnn AnnWhere (AR { InTreeAnnotations1.hs:2:27-31 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { InTreeAnnotations1.hs:9:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { InTreeAnnotations1.hs:9:1 }))])) + (VirtualBraces + (1)) + (Just + (L + { InTreeAnnotations1.hs:2:8-25 } + {ModuleName: InTreeAnnotations1})) + (Nothing) + [] + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:1-31 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { InTreeAnnotations1.hs:4:1-31 }) + (ValD + (NoExtField) + (FunBind + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-3 }) + (Unqual + {OccName: foo})) + (MG + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-31 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-31 }) + (Match + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:1-31 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (FunRhs + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:1-3 }) + (Unqual + {OccName: foo})) + (Prefix) + (NoSrcStrict)) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:5-11 }) + (AsPat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:5-11 } + (UnchangedAnchor)) + [(AddApiAnn AnnAt (AR { InTreeAnnotations1.hs:4:6 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:5 }) + (Unqual + {OccName: a})) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:7-11 }) + (TuplePat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:7-11 } + (UnchangedAnchor)) + [(AddApiAnn AnnOpenP (AR { InTreeAnnotations1.hs:4:7 })) + ,(AddApiAnn AnnCloseP (AR { InTreeAnnotations1.hs:4:11 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:8 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { InTreeAnnotations1.hs:4:9 }))]) + (AnnComments + [])) { InTreeAnnotations1.hs:4:8 }) + (WildPat + (NoExtField))) + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:10 }) + (WildPat + (NoExtField)))] + (Boxed))))) + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:13-16 }) + (BangPat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:13-16 } + (UnchangedAnchor)) + [(AddApiAnn AnnBang (AR { InTreeAnnotations1.hs:4:13 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:14-16 }) + (LitPat + (NoExtField) + (HsString + (SourceText "a") + {FastString: "a"}))))) + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:18-19 }) + (LazyPat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:18-19 } + (UnchangedAnchor)) + [(AddApiAnn AnnTilde (AR { InTreeAnnotations1.hs:4:18 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:19 }) + (VarPat + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:19 }) + (Unqual + {OccName: x}))))))] + (GRHSs + (NoExtField) + [(L + { InTreeAnnotations1.hs:4:21-31 } + (GRHS + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:4:21-31 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:4:21 }))) + (AnnComments + [])) + [] + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:23-31 }) + (HsVar + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:4:23-31 }) + (Unqual + {OccName: undefined}))))))] + (EmptyLocalBinds + (NoExtField)))))]) + (FromSource)) + []))) + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:1-27 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { InTreeAnnotations1.hs:6:1-27 }) + (TyClD + (NoExtField) + (DataDecl + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:1-27 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { InTreeAnnotations1.hs:6:1-4 })) + ,(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:6:8 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:6 }) + (Unqual + {OccName: T})) + (HsQTvs + (NoExtField) + []) + (Prefix) + (HsDataDefn + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:1-27 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { InTreeAnnotations1.hs:6:1-4 })) + ,(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:6:8 }))] + (AnnComments + [])) + (DataType) + (Nothing) + (Nothing) + (Nothing) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:10-27 }) + (ConDeclH98 + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:10-27 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:10-12 }) + (Unqual + {OccName: MkT})) + (False) + [] + (Nothing) + (RecCon + (L + (SrcSpanAnn (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:14 } + (UnchangedAnchor)) + (AnnList + (Just + (Anchor + { InTreeAnnotations1.hs:6:16-25 } + (UnchangedAnchor))) + (Just + (AddApiAnn AnnOpenC (AR { InTreeAnnotations1.hs:6:14 }))) + (Just + (AddApiAnn AnnCloseC (AR { InTreeAnnotations1.hs:6:27 }))) + [] + []) + (AnnComments + [])) { InTreeAnnotations1.hs:6:14-27 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:16-25 }) + (ConDeclField + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:16-18 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { InTreeAnnotations1.hs:6:20-21 }))] + (AnnComments + [])) + [(L + { InTreeAnnotations1.hs:6:16 } + (FieldOcc + (NoExtField) + (L + (SrcSpanAnn (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:16 } + (UnchangedAnchor)) + (NameAnnTrailing + [(AddCommaAnn + (AR { InTreeAnnotations1.hs:6:17 }))]) + (AnnComments + [])) { InTreeAnnotations1.hs:6:16 }) + (Unqual + {OccName: x})))) + ,(L + { InTreeAnnotations1.hs:6:18 } + (FieldOcc + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:18 }) + (Unqual + {OccName: y}))))] + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:23-25 }) + (HsTyVar + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:6:23-25 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (NotPromoted) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:6:23-25 }) + (Unqual + {OccName: Int})))) + (Nothing)))])) + (Nothing)))] + [])))) + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:1-43 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { InTreeAnnotations1.hs:8:1-43 }) + (ValD + (NoExtField) + (FunBind + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1 }) + (Unqual + {OccName: f})) + (MG + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1-43 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1-43 }) + (Match + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:1-43 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (FunRhs + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:1 }) + (Unqual + {OccName: f})) + (Prefix) + (NoSrcStrict)) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:3-35 }) + (ParPat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:3-35 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { InTreeAnnotations1.hs:8:3 }) + (AR { InTreeAnnotations1.hs:8:35 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:4-34 }) + (ConPat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:4-34 } + (UnchangedAnchor)) + [(AddApiAnn AnnOpenC (AR { InTreeAnnotations1.hs:8:8 })) + ,(AddApiAnn AnnCloseC (AR { InTreeAnnotations1.hs:8:34 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:4-6 }) + (Unqual + {OccName: MkT})) + (RecCon + (HsRecFields + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:10-15 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { InTreeAnnotations1.hs:8:16 }))]) + (AnnComments + [])) { InTreeAnnotations1.hs:8:10-15 }) + (HsRecField + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:10 } + (UnchangedAnchor)) + [(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:8:12 }))] + (AnnComments + [])) + (L + { InTreeAnnotations1.hs:8:10 } + (FieldOcc + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:10 }) + (Unqual + {OccName: x})))) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:14-15 }) + (BangPat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:14-15 } + (UnchangedAnchor)) + [(AddApiAnn AnnBang (AR { InTreeAnnotations1.hs:8:14 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:15 }) + (VarPat + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:15 }) + (Unqual + {OccName: v})))))) + (False))) + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:18-32 }) + (HsRecField + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:18 } + (UnchangedAnchor)) + [(AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:8:20 }))] + (AnnComments + [])) + (L + { InTreeAnnotations1.hs:8:18 } + (FieldOcc + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:18 }) + (Unqual + {OccName: y})))) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:22-32 }) + (ViewPat + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:22-32 } + (UnchangedAnchor)) + [(AddApiAnn AnnRarrow (AR { InTreeAnnotations1.hs:8:29-30 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:22-27 }) + (HsVar + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:22-27 }) + (Unqual + {OccName: negate})))) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:32 }) + (VarPat + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:32 }) + (Unqual + {OccName: w})))))) + (False)))] + (Nothing)))))))] + (GRHSs + (NoExtField) + [(L + { InTreeAnnotations1.hs:8:37-43 } + (GRHS + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:37-43 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddApiAnn AnnEqual (AR { InTreeAnnotations1.hs:8:37 }))) + (AnnComments + [])) + [] + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:39-43 }) + (OpApp + (ApiAnn + (Anchor + { InTreeAnnotations1.hs:8:39-43 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:39 }) + (HsVar + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:39 }) + (Unqual + {OccName: v})))) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:41 }) + (HsVar + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:41 }) + (Unqual + {OccName: +})))) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:43 }) + (HsVar + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { InTreeAnnotations1.hs:8:43 }) + (Unqual + {OccName: w}))))))))] + (EmptyLocalBinds + (NoExtField)))))]) + (FromSource)) + [])))] + (Nothing) + (Nothing))) diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile index a9bd5b36da..23151ea43a 100644 --- a/testsuite/tests/ghc-api/annotations/Makefile +++ b/testsuite/tests/ghc-api/annotations/Makefile @@ -4,10 +4,8 @@ include $(TOP)/mk/test.mk clean: rm -f *.o *.hi - rm -f annotations comments parseTree - rm -f listcomps + rm -f annotations comments rm -f stringSource - rm -f t11430 .PHONY: annotations annotations: @@ -15,162 +13,20 @@ annotations: '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc annotations ./annotations "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" -.PHONY: parseTree -parseTree: - rm -f parseTree.o parseTree.hi - '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc parseTree - ./parseTree "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" - .PHONY: comments comments: rm -f comments.o comments.hi '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc comments ./comments "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" -.PHONY: exampleTest -exampleTest: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" AnnotationTuple.hs - -.PHONY: listcomps -listcomps: - rm -f listcomps.o listcomps.hi - '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc listcomps - ./listcomps "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" - -.PHONY: T10358 -T10358: - # Ignore result code, we have an unattached (superfluous) AnnBang - - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10358.hs - -.PHONY: T10396 -T10396: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10396.hs - -.PHONY: T10255 -T10255: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10255.hs - -.PHONY: T10357 -T10357: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10357.hs - -.PHONY: T10268 -T10268: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10268.hs - -.PHONY: T10280 -T10280: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10280.hs - -.PHONY: T10269 -T10269: - # Ignore result code, we have an unattached (superfluous) AnnVal - - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10269.hs - -.PHONY: T10312 -T10312: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10312.hs - -.PHONY: T10307 -T10307: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10307.hs - -.PHONY: T10309 -T10309: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10309.hs - -.PHONY: boolFormula -boolFormula: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" TestBoolFormula.hs - -.PHONY: T10278 -T10278: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10278.hs - -.PHONY: T10354 -T10354: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10354.hs - -.PHONY: T10399 -T10399: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10399.hs - -.PHONY: bundle-export -bundle-export: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" BundleExport.hs - -.PHONY: T10313 -T10313: - rm -f stringSource.o stringSource.hi - '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc stringSource - ./stringSource "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10313 - -.PHONY: T11018 -T11018: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11018.hs - -.PHONY: T10276 -T10276: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10276.hs - -.PHONY: T10598 -T10598: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10598.hs - -.PHONY: T11321 -T11321: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11321.hs - -.PHONY: T11332 -T11332: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11332.hs - -.PHONY: T11430 -T11430: - rm -f t11430.o t11430.hi t11430 - '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t11430 - ./t11430 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11430 - -.PHONY: load-main -load-main: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" load-main.hs - -.PHONY: T12417 -T12417: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test12417.hs - -.PHONY: T13163 -T13163: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test13163.hs - -.PHONY: T15303 -T15303: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test15303.hs - -.PHONY: T16212 -T16212: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16212.hs - -.PHONY: T16230 -T16230: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16230.hs - -.PHONY: T16236 -T16236: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16236.hs - -.PHONY: StarBinderAnns -StarBinderAnns: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" StarBinderAnns.hs - -.PHONY: T16279 -T16279: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16279.hs - -.PHONY: T17388 -T17388: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17388.hs - -.PHONY: T17519 -T17519: - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17519.hs +# .PHONY: T10313 +# T10313: +# rm -f stringSource.o stringSource.hi +# '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc stringSource +# ./stringSource "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10313 + +# .PHONY: T11430 +# T11430: +# rm -f t11430.o t11430.hi t11430 +# '$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -package ghc t11430 +# ./t11430 "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11430 diff --git a/testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout b/testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout deleted file mode 100644 index 9d063f0934..0000000000 --- a/testsuite/tests/ghc-api/annotations/StarBinderAnns.stdout +++ /dev/null @@ -1,38 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((StarBinderAnns.hs:1:1,AnnModule), [StarBinderAnns.hs:4:1-6]), -((StarBinderAnns.hs:1:1,AnnWhere), [StarBinderAnns.hs:4:23-27]), -((StarBinderAnns.hs:4:10-21,AnnCloseP), [StarBinderAnns.hs:4:21]), -((StarBinderAnns.hs:4:10-21,AnnOpenP), [StarBinderAnns.hs:4:10]), -((StarBinderAnns.hs:4:11-20,AnnType), [StarBinderAnns.hs:4:11-14]), -((StarBinderAnns.hs:4:16-20,AnnCloseP), [StarBinderAnns.hs:4:20]), -((StarBinderAnns.hs:4:16-20,AnnOpenP), [StarBinderAnns.hs:4:16]), -((StarBinderAnns.hs:4:16-20,AnnVal), [StarBinderAnns.hs:4:17-19]), -((StarBinderAnns.hs:6:1-19,AnnCloseC), [StarBinderAnns.hs:6:50]), -((StarBinderAnns.hs:6:1-19,AnnCloseP), [StarBinderAnns.hs:6:15]), -((StarBinderAnns.hs:6:1-19,AnnFamily), [StarBinderAnns.hs:6:6-11]), -((StarBinderAnns.hs:6:1-19,AnnOpenC), [StarBinderAnns.hs:6:27]), -((StarBinderAnns.hs:6:1-19,AnnOpenP), [StarBinderAnns.hs:6:13]), -((StarBinderAnns.hs:6:1-19,AnnSemi), [StarBinderAnns.hs:7:1]), -((StarBinderAnns.hs:6:1-19,AnnType), [StarBinderAnns.hs:6:1-4]), -((StarBinderAnns.hs:6:1-19,AnnWhere), [StarBinderAnns.hs:6:21-25]), -((StarBinderAnns.hs:6:13-15,AnnCloseP), [StarBinderAnns.hs:6:15]), -((StarBinderAnns.hs:6:13-15,AnnOpenP), [StarBinderAnns.hs:6:13]), -((StarBinderAnns.hs:6:29-31,AnnCloseP), [StarBinderAnns.hs:6:31]), -((StarBinderAnns.hs:6:29-31,AnnOpenP), [StarBinderAnns.hs:6:29]), -((StarBinderAnns.hs:6:29-48,AnnCloseP), [StarBinderAnns.hs:6:31]), -((StarBinderAnns.hs:6:29-48,AnnEqual), [StarBinderAnns.hs:6:37]), -((StarBinderAnns.hs:6:29-48,AnnOpenP), [StarBinderAnns.hs:6:29]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "StarBinderAnns.hs" 7 1 diff --git a/testsuite/tests/ghc-api/annotations/T10255.stdout b/testsuite/tests/ghc-api/annotations/T10255.stdout deleted file mode 100644 index 15df1b7f44..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10255.stdout +++ /dev/null @@ -1,29 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10255.hs:1:1,AnnModule), [Test10255.hs:2:1-6]), -((Test10255.hs:1:1,AnnWhere), [Test10255.hs:2:18-22]), -((Test10255.hs:4:1-17,AnnImport), [Test10255.hs:4:1-6]), -((Test10255.hs:4:1-17,AnnSemi), [Test10255.hs:6:1]), -((Test10255.hs:(6,1)-(7,11),AnnEqual), [Test10255.hs:6:29]), -((Test10255.hs:(6,1)-(7,11),AnnFunId), [Test10255.hs:6:1-3]), -((Test10255.hs:(6,1)-(7,11),AnnSemi), [Test10255.hs:8:1]), -((Test10255.hs:6:5-27,AnnCloseP), [Test10255.hs:6:27]), -((Test10255.hs:6:5-27,AnnOpenP), [Test10255.hs:6:5]), -((Test10255.hs:6:6-26,AnnDcolon), [Test10255.hs:6:8-9]), -((Test10255.hs:6:11-26,AnnCloseP), [Test10255.hs:6:26]), -((Test10255.hs:6:11-26,AnnOpenP), [Test10255.hs:6:11]), -((Test10255.hs:6:12-18,AnnRarrow), [Test10255.hs:6:20-21]), -((Test10255.hs:6:12-25,AnnRarrow), [Test10255.hs:6:20-21]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10255.hs" 8 1 diff --git a/testsuite/tests/ghc-api/annotations/T10268.stdout b/testsuite/tests/ghc-api/annotations/T10268.stdout deleted file mode 100644 index 906632a59b..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10268.stdout +++ /dev/null @@ -1,39 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10268.hs:1:1,AnnModule), [Test10268.hs:3:1-6]), -((Test10268.hs:1:1,AnnWhere), [Test10268.hs:3:18-22]), -((Test10268.hs:5:1-17,AnnEqual), [Test10268.hs:5:4]), -((Test10268.hs:5:1-17,AnnFunId), [Test10268.hs:5:1-2]), -((Test10268.hs:5:1-17,AnnSemi), [Test10268.hs:7:1]), -((Test10268.hs:5:6-17,AnnDollar), [Test10268.hs:5:6]), -((Test10268.hs:7:1-27,AnnDcolon), [Test10268.hs:7:6-7]), -((Test10268.hs:7:1-27,AnnSemi), [Test10268.hs:8:1]), -((Test10268.hs:7:9,AnnRarrow), [Test10268.hs:7:11-12]), -((Test10268.hs:7:9-27,AnnRarrow), [Test10268.hs:7:11-12]), -((Test10268.hs:7:22-25,AnnCloseS), [Test10268.hs:7:25]), -((Test10268.hs:7:22-25,AnnOpenS), [Test10268.hs:7:23]), -((Test10268.hs:7:22-25,AnnSimpleQuote), [Test10268.hs:7:22]), -((Test10268.hs:8:1-16,AnnEqual), [Test10268.hs:8:6]), -((Test10268.hs:8:1-16,AnnFunId), [Test10268.hs:8:1-4]), -((Test10268.hs:8:1-16,AnnSemi), [Test10268.hs:10:1]), -((Test10268.hs:10:1-22,AnnDcolon), [Test10268.hs:10:7-8]), -((Test10268.hs:10:1-22,AnnSemi), [Test10268.hs:11:1]), -((Test10268.hs:10:18-20,AnnCloseS), [Test10268.hs:10:20]), -((Test10268.hs:10:18-20,AnnOpenS), [Test10268.hs:10:19]), -((Test10268.hs:10:18-20,AnnSimpleQuote), [Test10268.hs:10:18]), -((Test10268.hs:11:1-17,AnnEqual), [Test10268.hs:11:7]), -((Test10268.hs:11:1-17,AnnFunId), [Test10268.hs:11:1-5]), -((Test10268.hs:11:1-17,AnnSemi), [Test10268.hs:12:1]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10268.hs" 12 1 diff --git a/testsuite/tests/ghc-api/annotations/T10269.stdout b/testsuite/tests/ghc-api/annotations/T10269.stdout deleted file mode 100644 index b0946e1812..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10269.stdout +++ /dev/null @@ -1,25 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[(AnnVal, Test10269.hs:4:4-6)] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10269.hs:1:1,AnnModule), [Test10269.hs:1:1-6]), -((Test10269.hs:1:1,AnnWhere), [Test10269.hs:1:18-22]), -((Test10269.hs:4:1-9,AnnCloseP), [Test10269.hs:4:9]), -((Test10269.hs:4:1-9,AnnOpenP), [Test10269.hs:4:1]), -((Test10269.hs:4:1-26,AnnCloseP), [Test10269.hs:4:9]), -((Test10269.hs:4:1-26,AnnEqual), [Test10269.hs:4:16]), -((Test10269.hs:4:1-26,AnnFunId), [Test10269.hs:4:4-6]), -((Test10269.hs:4:1-26,AnnOpenP), [Test10269.hs:4:1]), -((Test10269.hs:4:1-26,AnnSemi), [Test10269.hs:5:1]), -((Test10269.hs:4:2-8,AnnVal), [Test10269.hs:4:4-6]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10269.hs" 5 1 diff --git a/testsuite/tests/ghc-api/annotations/T10276.stdout b/testsuite/tests/ghc-api/annotations/T10276.stdout deleted file mode 100644 index 4c53170e2c..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10276.stdout +++ /dev/null @@ -1,71 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10276.hs:1:1,AnnModule), [Test10276.hs:4:1-6]), -((Test10276.hs:1:1,AnnWhere), [Test10276.hs:4:18-22]), -((Test10276.hs:6:1-14,AnnEqual), [Test10276.hs:6:4]), -((Test10276.hs:6:1-14,AnnFunId), [Test10276.hs:6:1-2]), -((Test10276.hs:6:1-14,AnnSemi), [Test10276.hs:7:1]), -((Test10276.hs:6:6-14,AnnCloseQ), [Test10276.hs:6:13-14]), -((Test10276.hs:6:6-14,AnnOpenEQ), [Test10276.hs:6:6-7]), -((Test10276.hs:7:1-15,AnnEqual), [Test10276.hs:7:4]), -((Test10276.hs:7:1-15,AnnFunId), [Test10276.hs:7:1-2]), -((Test10276.hs:7:1-15,AnnSemi), [Test10276.hs:9:1]), -((Test10276.hs:7:6-15,AnnCloseQ), [Test10276.hs:7:14-15]), -((Test10276.hs:7:6-15,AnnOpenE), [Test10276.hs:7:6-8]), -((Test10276.hs:(9,1)-(11,74),AnnClass), [Test10276.hs:9:1-5]), -((Test10276.hs:(9,1)-(11,74),AnnSemi), [Test10276.hs:13:1]), -((Test10276.hs:(9,1)-(11,74),AnnWhere), [Test10276.hs:9:17-21]), -((Test10276.hs:(10,3)-(11,74),AnnEqual), [Test10276.hs:10:11]), -((Test10276.hs:(10,3)-(11,74),AnnFunId), [Test10276.hs:10:3-7]), -((Test10276.hs:(10,13)-(11,74),AnnClose), [Test10276.hs:11:72-74]), -((Test10276.hs:(10,13)-(11,74),AnnOpen), [Test10276.hs:10:13-15]), -((Test10276.hs:(10,16)-(11,71),AnnVal), [Test10276.hs:10:20]), -((Test10276.hs:10:31-42,AnnDollarDollar), [Test10276.hs:10:31-32]), -((Test10276.hs:10:33-42,AnnCloseP), [Test10276.hs:10:42]), -((Test10276.hs:10:33-42,AnnOpenP), [Test10276.hs:10:33]), -((Test10276.hs:11:25-71,AnnCloseP), [Test10276.hs:11:71]), -((Test10276.hs:11:25-71,AnnOpenP), [Test10276.hs:11:25]), -((Test10276.hs:11:26-36,AnnCloseP), [Test10276.hs:11:36]), -((Test10276.hs:11:26-36,AnnOpenP), [Test10276.hs:11:26]), -((Test10276.hs:11:26-70,AnnDcolon), [Test10276.hs:11:38-39]), -((Test10276.hs:11:27,AnnComma), [Test10276.hs:11:28]), -((Test10276.hs:11:41-70,AnnCloseP), [Test10276.hs:11:70]), -((Test10276.hs:11:41-70,AnnOpenP), [Test10276.hs:11:41]), -((Test10276.hs:11:42-44,AnnComma), [Test10276.hs:11:45]), -((Test10276.hs:11:59-69,AnnCloseS), [Test10276.hs:11:69]), -((Test10276.hs:11:59-69,AnnOpenS), [Test10276.hs:11:59]), -((Test10276.hs:(13,1)-(15,74),AnnClass), [Test10276.hs:13:1-5]), -((Test10276.hs:(13,1)-(15,74),AnnSemi), [Test10276.hs:16:1]), -((Test10276.hs:(13,1)-(15,74),AnnWhere), [Test10276.hs:13:18-22]), -((Test10276.hs:(14,3)-(15,74),AnnEqual), [Test10276.hs:14:11]), -((Test10276.hs:(14,3)-(15,74),AnnFunId), [Test10276.hs:14:3-7]), -((Test10276.hs:(14,13)-(15,74),AnnClose), [Test10276.hs:15:72-74]), -((Test10276.hs:(14,13)-(15,74),AnnOpenE), [Test10276.hs:14:13-16]), -((Test10276.hs:(14,17)-(15,71),AnnVal), [Test10276.hs:14:21]), -((Test10276.hs:14:32-43,AnnDollarDollar), [Test10276.hs:14:32-33]), -((Test10276.hs:14:34-43,AnnCloseP), [Test10276.hs:14:43]), -((Test10276.hs:14:34-43,AnnOpenP), [Test10276.hs:14:34]), -((Test10276.hs:15:25-71,AnnCloseP), [Test10276.hs:15:71]), -((Test10276.hs:15:25-71,AnnOpenP), [Test10276.hs:15:25]), -((Test10276.hs:15:26-36,AnnCloseP), [Test10276.hs:15:36]), -((Test10276.hs:15:26-36,AnnOpenP), [Test10276.hs:15:26]), -((Test10276.hs:15:26-70,AnnDcolon), [Test10276.hs:15:38-39]), -((Test10276.hs:15:27,AnnComma), [Test10276.hs:15:28]), -((Test10276.hs:15:41-70,AnnCloseP), [Test10276.hs:15:70]), -((Test10276.hs:15:41-70,AnnOpenP), [Test10276.hs:15:41]), -((Test10276.hs:15:42-44,AnnComma), [Test10276.hs:15:45]), -((Test10276.hs:15:59-69,AnnCloseS), [Test10276.hs:15:69]), -((Test10276.hs:15:59-69,AnnOpenS), [Test10276.hs:15:59]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10276.hs" 16 1 diff --git a/testsuite/tests/ghc-api/annotations/T10278.stdout b/testsuite/tests/ghc-api/annotations/T10278.stdout deleted file mode 100644 index 7c029c6c06..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10278.stdout +++ /dev/null @@ -1,99 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10278.hs:1:1,AnnModule), [Test10278.hs:2:1-6]), -((Test10278.hs:1:1,AnnWhere), [Test10278.hs:2:18-22]), -((Test10278.hs:4:1-61,AnnDcolon), [Test10278.hs:4:16-17]), -((Test10278.hs:4:1-61,AnnSemi), [Test10278.hs:5:1]), -((Test10278.hs:4:19-61,AnnDot), [Test10278.hs:4:29]), -((Test10278.hs:4:19-61,AnnForall), [Test10278.hs:4:19-24]), -((Test10278.hs:4:31-61,AnnDot), [Test10278.hs:4:42]), -((Test10278.hs:4:31-61,AnnForall), [Test10278.hs:4:31-36]), -((Test10278.hs:4:44-46,AnnRarrow), [Test10278.hs:4:48-49]), -((Test10278.hs:4:44-61,AnnRarrow), [Test10278.hs:4:48-49]), -((Test10278.hs:4:51-54,AnnRarrow), [Test10278.hs:4:56-57]), -((Test10278.hs:4:51-61,AnnRarrow), [Test10278.hs:4:56-57]), -((Test10278.hs:5:1-26,AnnEqual), [Test10278.hs:5:16]), -((Test10278.hs:5:1-26,AnnFunId), [Test10278.hs:5:1-14]), -((Test10278.hs:5:1-26,AnnSemi), [Test10278.hs:7:1]), -((Test10278.hs:(7,1)-(11,33),AnnDcolon), [Test10278.hs:7:17-18]), -((Test10278.hs:(7,1)-(11,33),AnnSemi), [Test10278.hs:12:1]), -((Test10278.hs:7:20-39,AnnCloseP), [Test10278.hs:7:39, Test10278.hs:7:39]), -((Test10278.hs:7:20-39,AnnDarrow), [Test10278.hs:7:41-42]), -((Test10278.hs:7:20-39,AnnOpenP), [Test10278.hs:7:20, Test10278.hs:7:20]), -((Test10278.hs:7:21-24,AnnComma), [Test10278.hs:7:25]), -((Test10278.hs:(8,19)-(10,58),AnnCloseP), [Test10278.hs:10:58]), -((Test10278.hs:(8,19)-(10,58),AnnOpenP), [Test10278.hs:8:19]), -((Test10278.hs:(8,19)-(10,58),AnnRarrow), [Test10278.hs:11:23-24]), -((Test10278.hs:(8,19)-(11,33),AnnRarrow), [Test10278.hs:11:23-24]), -((Test10278.hs:(8,20)-(10,57),AnnDot), [Test10278.hs:8:30]), -((Test10278.hs:(8,20)-(10,57),AnnForall), [Test10278.hs:8:20-25]), -((Test10278.hs:(8,32)-(10,57),AnnDot), [Test10278.hs:8:43]), -((Test10278.hs:(8,32)-(10,57),AnnForall), [Test10278.hs:8:32-37]), -((Test10278.hs:9:27-50,AnnRarrow), [Test10278.hs:10:31-32]), -((Test10278.hs:(9,27)-(10,57),AnnRarrow), [Test10278.hs:10:31-32]), -((Test10278.hs:9:38-50,AnnCloseP), [Test10278.hs:9:50]), -((Test10278.hs:9:38-50,AnnOpenP), [Test10278.hs:9:38]), -((Test10278.hs:10:45-57,AnnCloseP), [Test10278.hs:10:57]), -((Test10278.hs:10:45-57,AnnOpenP), [Test10278.hs:10:45]), -((Test10278.hs:11:26,AnnRarrow), [Test10278.hs:11:28-29]), -((Test10278.hs:11:26-33,AnnRarrow), [Test10278.hs:11:28-29]), -((Test10278.hs:11:31-33,AnnCloseS), [Test10278.hs:11:33]), -((Test10278.hs:11:31-33,AnnOpenS), [Test10278.hs:11:31]), -((Test10278.hs:12:1-47,AnnEqual), [Test10278.hs:12:22]), -((Test10278.hs:12:1-47,AnnFunId), [Test10278.hs:12:1-15]), -((Test10278.hs:12:1-47,AnnSemi), [Test10278.hs:14:1]), -((Test10278.hs:12:35-44,AnnCloseP), [Test10278.hs:12:44]), -((Test10278.hs:12:35-44,AnnOpenP), [Test10278.hs:12:35]), -((Test10278.hs:(14,1)-(17,80),AnnData), [Test10278.hs:14:1-4]), -((Test10278.hs:(14,1)-(17,80),AnnSemi), [Test10278.hs:21:1]), -((Test10278.hs:(14,1)-(17,80),AnnWhere), [Test10278.hs:14:21-25]), -((Test10278.hs:15:5-64,AnnDcolon), [Test10278.hs:15:11-12]), -((Test10278.hs:15:5-64,AnnSemi), [Test10278.hs:16:5]), -((Test10278.hs:15:14-64,AnnDot), [Test10278.hs:15:23]), -((Test10278.hs:15:14-64,AnnForall), [Test10278.hs:15:14-19]), -((Test10278.hs:15:25-40,AnnCloseP), [Test10278.hs:15:40, Test10278.hs:15:40]), -((Test10278.hs:15:25-40,AnnDarrow), [Test10278.hs:15:42-43]), -((Test10278.hs:15:25-40,AnnOpenP), [Test10278.hs:15:25, Test10278.hs:15:25]), -((Test10278.hs:15:27-30,AnnComma), [Test10278.hs:15:31]), -((Test10278.hs:15:45-46,AnnBang), [Test10278.hs:15:45]), -((Test10278.hs:15:45-46,AnnRarrow), [Test10278.hs:15:48-49]), -((Test10278.hs:15:45-64,AnnRarrow), [Test10278.hs:15:48-49]), -((Test10278.hs:16:5-64,AnnDcolon), [Test10278.hs:16:11-12]), -((Test10278.hs:16:5-64,AnnSemi), [Test10278.hs:17:5]), -((Test10278.hs:16:14-64,AnnDot), [Test10278.hs:16:23]), -((Test10278.hs:16:14-64,AnnForall), [Test10278.hs:16:14-19]), -((Test10278.hs:16:25-40,AnnCloseP), [Test10278.hs:16:40, Test10278.hs:16:40]), -((Test10278.hs:16:25-40,AnnDarrow), [Test10278.hs:16:42-43]), -((Test10278.hs:16:25-40,AnnOpenP), [Test10278.hs:16:25, Test10278.hs:16:25]), -((Test10278.hs:16:27-30,AnnComma), [Test10278.hs:16:31]), -((Test10278.hs:16:45-46,AnnBang), [Test10278.hs:16:45]), -((Test10278.hs:16:45-46,AnnRarrow), [Test10278.hs:16:48-49]), -((Test10278.hs:16:45-64,AnnRarrow), [Test10278.hs:16:48-49]), -((Test10278.hs:17:5-80,AnnDcolon), [Test10278.hs:17:12-13]), -((Test10278.hs:17:15-20,AnnCloseP), [Test10278.hs:17:20]), -((Test10278.hs:17:15-20,AnnDarrow), [Test10278.hs:17:22-23]), -((Test10278.hs:17:15-20,AnnOpenP), [Test10278.hs:17:15]), -((Test10278.hs:17:25-80,AnnDot), [Test10278.hs:17:34]), -((Test10278.hs:17:25-80,AnnForall), [Test10278.hs:17:25-30]), -((Test10278.hs:17:36-51,AnnCloseP), [Test10278.hs:17:51, Test10278.hs:17:51]), -((Test10278.hs:17:36-51,AnnDarrow), [Test10278.hs:17:53-54]), -((Test10278.hs:17:36-51,AnnOpenP), [Test10278.hs:17:36, Test10278.hs:17:36]), -((Test10278.hs:17:38-41,AnnComma), [Test10278.hs:17:42]), -((Test10278.hs:17:56-57,AnnBang), [Test10278.hs:17:56]), -((Test10278.hs:17:56-57,AnnRarrow), [Test10278.hs:17:59-60]), -((Test10278.hs:17:56-80,AnnRarrow), [Test10278.hs:17:59-60]), -((Test10278.hs:17:62,AnnRarrow), [Test10278.hs:17:64-65]), -((Test10278.hs:17:62-80,AnnRarrow), [Test10278.hs:17:64-65]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10278.hs" 21 1 diff --git a/testsuite/tests/ghc-api/annotations/T10280.stdout b/testsuite/tests/ghc-api/annotations/T10280.stdout deleted file mode 100644 index e291777a0e..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10280.stdout +++ /dev/null @@ -1,28 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10280.hs:1:1,AnnModule), [Test10280.hs:2:1-6]), -((Test10280.hs:1:1,AnnWhere), [Test10280.hs:2:18-22]), -((Test10280.hs:4:1-45,AnnEqual), [Test10280.hs:4:6]), -((Test10280.hs:4:1-45,AnnFunId), [Test10280.hs:4:1-4]), -((Test10280.hs:4:1-45,AnnSemi), [Test10280.hs:5:1]), -((Test10280.hs:4:35-45,AnnCloseP), [Test10280.hs:4:45]), -((Test10280.hs:4:35-45,AnnOpenP), [Test10280.hs:4:35]), -((Test10280.hs:4:36-40,AnnCloseP), [Test10280.hs:4:40]), -((Test10280.hs:4:36-40,AnnOpenP), [Test10280.hs:4:36]), -((Test10280.hs:4:36-44,AnnVal), [Test10280.hs:4:42]), -((Test10280.hs:4:37,AnnComma), [Test10280.hs:4:37]), -((Test10280.hs:4:38-39,AnnCloseP), [Test10280.hs:4:39]), -((Test10280.hs:4:38-39,AnnOpenP), [Test10280.hs:4:38]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10280.hs" 5 1 diff --git a/testsuite/tests/ghc-api/annotations/T10307.stdout b/testsuite/tests/ghc-api/annotations/T10307.stdout deleted file mode 100644 index 163bfb6b82..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10307.stdout +++ /dev/null @@ -1,28 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10307.hs:1:1,AnnModule), [Test10307.hs:2:1-6]), -((Test10307.hs:1:1,AnnWhere), [Test10307.hs:2:18-22]), -((Test10307.hs:(4,1)-(6,34),AnnClass), [Test10307.hs:4:1-5]), -((Test10307.hs:(4,1)-(6,34),AnnSemi), [Test10307.hs:7:1]), -((Test10307.hs:(4,1)-(6,34),AnnWhere), [Test10307.hs:4:18-22]), -((Test10307.hs:5:3-34,AnnDcolon), [Test10307.hs:5:31-32]), -((Test10307.hs:5:3-34,AnnSemi), [Test10307.hs:6:3]), -((Test10307.hs:5:3-34,AnnType), [Test10307.hs:5:3-6]), -((Test10307.hs:6:3-34,AnnEqual), [Test10307.hs:6:31]), -((Test10307.hs:6:3-34,AnnType), [Test10307.hs:6:3-6]), -((Test10307.hs:6:8-34,AnnEqual), [Test10307.hs:6:31]), -((Test10307.hs:6:33-34,AnnCloseP), [Test10307.hs:6:34]), -((Test10307.hs:6:33-34,AnnOpenP), [Test10307.hs:6:33]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10307.hs" 7 1 diff --git a/testsuite/tests/ghc-api/annotations/T10309.stdout b/testsuite/tests/ghc-api/annotations/T10309.stdout deleted file mode 100644 index a929c1b70c..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10309.stdout +++ /dev/null @@ -1,29 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10309.hs:1:1,AnnModule), [Test10309.hs:2:1-6]), -((Test10309.hs:1:1,AnnWhere), [Test10309.hs:2:18-22]), -((Test10309.hs:(4,1)-(6,34),AnnData), [Test10309.hs:4:1-4]), -((Test10309.hs:(4,1)-(6,34),AnnSemi), [Test10309.hs:7:1]), -((Test10309.hs:(4,1)-(6,34),AnnWhere), [Test10309.hs:4:13-17]), -((Test10309.hs:(5,3)-(6,34),AnnDcolon), [Test10309.hs:5:6-7]), -((Test10309.hs:5:9-15,AnnCloseP), [Test10309.hs:5:15]), -((Test10309.hs:5:9-15,AnnDarrow), [Test10309.hs:5:17-18]), -((Test10309.hs:5:9-15,AnnOpenP), [Test10309.hs:5:9]), -((Test10309.hs:(5,20)-(6,20),AnnCloseC), [Test10309.hs:6:20]), -((Test10309.hs:(5,20)-(6,20),AnnOpenC), [Test10309.hs:5:20]), -((Test10309.hs:(5,20)-(6,20),AnnRarrow), [Test10309.hs:6:22-23]), -((Test10309.hs:(5,20)-(6,34),AnnRarrow), [Test10309.hs:6:22-23]), -((Test10309.hs:5:22-31,AnnDcolon), [Test10309.hs:5:28-29]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10309.hs" 7 1 diff --git a/testsuite/tests/ghc-api/annotations/T10312.stdout b/testsuite/tests/ghc-api/annotations/T10312.stdout deleted file mode 100644 index 5a46df4f86..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10312.stdout +++ /dev/null @@ -1,258 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10312.hs:1:1,AnnModule), [Test10312.hs:4:1-6]), -((Test10312.hs:1:1,AnnWhere), [Test10312.hs:4:18-22]), -((Test10312.hs:8:1-15,AnnImport), [Test10312.hs:8:1-6]), -((Test10312.hs:8:1-15,AnnSemi), [Test10312.hs:9:1]), -((Test10312.hs:9:1-30,AnnAs), [Test10312.hs:9:27-28]), -((Test10312.hs:9:1-30,AnnImport), [Test10312.hs:9:1-6]), -((Test10312.hs:9:1-30,AnnQualified), [Test10312.hs:9:8-16]), -((Test10312.hs:9:1-30,AnnSemi), [Test10312.hs:10:1]), -((Test10312.hs:10:1-27,AnnImport), [Test10312.hs:10:1-6]), -((Test10312.hs:10:1-27,AnnSemi), [Test10312.hs:11:1]), -((Test10312.hs:10:17-27,AnnCloseP), [Test10312.hs:10:27]), -((Test10312.hs:10:17-27,AnnOpenP), [Test10312.hs:10:17]), -((Test10312.hs:11:1-25,AnnImport), [Test10312.hs:11:1-6]), -((Test10312.hs:11:1-25,AnnSemi), [Test10312.hs:15:1]), -((Test10312.hs:11:18-25,AnnCloseP), [Test10312.hs:11:25]), -((Test10312.hs:11:18-25,AnnOpenP), [Test10312.hs:11:18]), -((Test10312.hs:15:1-24,AnnDcolon), [Test10312.hs:15:17-18]), -((Test10312.hs:15:1-24,AnnSemi), [Test10312.hs:16:1]), -((Test10312.hs:15:20-24,AnnCloseS), [Test10312.hs:15:24]), -((Test10312.hs:15:20-24,AnnOpenS), [Test10312.hs:15:20]), -((Test10312.hs:(16,1)-(20,19),AnnEqual), [Test10312.hs:16:17]), -((Test10312.hs:(16,1)-(20,19),AnnFunId), [Test10312.hs:16:1-15]), -((Test10312.hs:(16,1)-(20,19),AnnSemi), [Test10312.hs:22:1]), -((Test10312.hs:(16,19)-(20,19),AnnCloseS), [Test10312.hs:20:19]), -((Test10312.hs:(16,19)-(20,19),AnnOpenS), [Test10312.hs:16:19]), -((Test10312.hs:(16,19)-(20,19),AnnVbar), [Test10312.hs:17:19]), -((Test10312.hs:16:21-25,AnnVal), [Test10312.hs:16:23]), -((Test10312.hs:16:21-29,AnnVal), [Test10312.hs:16:27]), -((Test10312.hs:17:21-32,AnnComma), [Test10312.hs:18:19]), -((Test10312.hs:17:21-32,AnnLarrow), [Test10312.hs:17:23-24]), -((Test10312.hs:17:26-32,AnnCloseS), [Test10312.hs:17:32]), -((Test10312.hs:17:26-32,AnnDotdot), [Test10312.hs:17:28-29]), -((Test10312.hs:17:26-32,AnnOpenS), [Test10312.hs:17:26]), -((Test10312.hs:18:21-33,AnnComma), [Test10312.hs:19:19]), -((Test10312.hs:18:21-33,AnnLarrow), [Test10312.hs:18:23-24]), -((Test10312.hs:18:26-33,AnnCloseS), [Test10312.hs:18:33]), -((Test10312.hs:18:26-33,AnnDotdot), [Test10312.hs:18:29-30]), -((Test10312.hs:18:26-33,AnnOpenS), [Test10312.hs:18:26]), -((Test10312.hs:19:21-33,AnnLarrow), [Test10312.hs:19:23-24]), -((Test10312.hs:19:26-33,AnnCloseS), [Test10312.hs:19:33]), -((Test10312.hs:19:26-33,AnnDotdot), [Test10312.hs:19:29-30]), -((Test10312.hs:19:26-33,AnnOpenS), [Test10312.hs:19:26]), -((Test10312.hs:22:1-25,AnnDcolon), [Test10312.hs:22:18-19]), -((Test10312.hs:22:1-25,AnnSemi), [Test10312.hs:23:1]), -((Test10312.hs:22:21-25,AnnCloseS), [Test10312.hs:22:25]), -((Test10312.hs:22:21-25,AnnOpenS), [Test10312.hs:22:21]), -((Test10312.hs:(23,1)-(27,20),AnnEqual), [Test10312.hs:23:18]), -((Test10312.hs:(23,1)-(27,20),AnnFunId), [Test10312.hs:23:1-16]), -((Test10312.hs:(23,1)-(27,20),AnnSemi), [Test10312.hs:32:1]), -((Test10312.hs:(23,20)-(27,20),AnnCloseS), [Test10312.hs:27:20]), -((Test10312.hs:(23,20)-(27,20),AnnOpenS), [Test10312.hs:23:20]), -((Test10312.hs:(23,20)-(27,20),AnnVbar), [Test10312.hs:24:20]), -((Test10312.hs:23:22-26,AnnVal), [Test10312.hs:23:24]), -((Test10312.hs:23:22-30,AnnVal), [Test10312.hs:23:28]), -((Test10312.hs:24:22-33,AnnLarrow), [Test10312.hs:24:24-25]), -((Test10312.hs:24:22-33,AnnVbar), [Test10312.hs:25:20]), -((Test10312.hs:24:27-33,AnnCloseS), [Test10312.hs:24:33]), -((Test10312.hs:24:27-33,AnnDotdot), [Test10312.hs:24:29-30]), -((Test10312.hs:24:27-33,AnnOpenS), [Test10312.hs:24:27]), -((Test10312.hs:25:22-34,AnnLarrow), [Test10312.hs:25:24-25]), -((Test10312.hs:25:22-34,AnnVbar), [Test10312.hs:26:20]), -((Test10312.hs:25:27-34,AnnCloseS), [Test10312.hs:25:34]), -((Test10312.hs:25:27-34,AnnDotdot), [Test10312.hs:25:30-31]), -((Test10312.hs:25:27-34,AnnOpenS), [Test10312.hs:25:27]), -((Test10312.hs:26:22-34,AnnLarrow), [Test10312.hs:26:24-25]), -((Test10312.hs:26:27-34,AnnCloseS), [Test10312.hs:26:34]), -((Test10312.hs:26:27-34,AnnDotdot), [Test10312.hs:26:30-31]), -((Test10312.hs:26:27-34,AnnOpenS), [Test10312.hs:26:27]), -((Test10312.hs:32:1-13,AnnDcolon), [Test10312.hs:32:6-7]), -((Test10312.hs:32:1-13,AnnSemi), [Test10312.hs:33:1]), -((Test10312.hs:32:9-13,AnnCloseS), [Test10312.hs:32:13]), -((Test10312.hs:32:9-13,AnnOpenS), [Test10312.hs:32:9]), -((Test10312.hs:(33,1)-(36,16),AnnEqual), [Test10312.hs:33:6]), -((Test10312.hs:(33,1)-(36,16),AnnFunId), [Test10312.hs:33:1-4]), -((Test10312.hs:(33,1)-(36,16),AnnSemi), [Test10312.hs:38:1]), -((Test10312.hs:33:8-12,AnnVal), [Test10312.hs:33:10]), -((Test10312.hs:(33,8)-(36,16),AnnVal), [Test10312.hs:33:14]), -((Test10312.hs:(33,16)-(36,16),AnnCloseS), [Test10312.hs:36:16]), -((Test10312.hs:(33,16)-(36,16),AnnOpenS), [Test10312.hs:33:16]), -((Test10312.hs:(33,16)-(36,16),AnnVbar), [Test10312.hs:34:16]), -((Test10312.hs:33:18-22,AnnVal), [Test10312.hs:33:20]), -((Test10312.hs:34:18-26,AnnLarrow), [Test10312.hs:34:20-21]), -((Test10312.hs:34:18-26,AnnVbar), [Test10312.hs:35:16]), -((Test10312.hs:35:18-31,AnnLarrow), [Test10312.hs:35:20-21]), -((Test10312.hs:38:1-17,AnnDcolon), [Test10312.hs:38:10-11]), -((Test10312.hs:38:1-17,AnnSemi), [Test10312.hs:39:1]), -((Test10312.hs:38:13-17,AnnCloseS), [Test10312.hs:38:17]), -((Test10312.hs:38:13-17,AnnOpenS), [Test10312.hs:38:13]), -((Test10312.hs:(39,1)-(43,20),AnnEqual), [Test10312.hs:39:10]), -((Test10312.hs:(39,1)-(43,20),AnnFunId), [Test10312.hs:39:1-8]), -((Test10312.hs:(39,1)-(43,20),AnnSemi), [Test10312.hs:46:1]), -((Test10312.hs:39:12-16,AnnVal), [Test10312.hs:39:14]), -((Test10312.hs:(39,12)-(43,20),AnnVal), [Test10312.hs:39:18]), -((Test10312.hs:(39,20)-(43,20),AnnCloseS), [Test10312.hs:43:20]), -((Test10312.hs:(39,20)-(43,20),AnnOpenS), [Test10312.hs:39:20]), -((Test10312.hs:(39,20)-(43,20),AnnVbar), [Test10312.hs:40:20]), -((Test10312.hs:39:22-26,AnnVal), [Test10312.hs:39:24]), -((Test10312.hs:39:22-30,AnnVal), [Test10312.hs:39:28]), -((Test10312.hs:40:22-30,AnnLarrow), [Test10312.hs:40:24-25]), -((Test10312.hs:40:22-30,AnnVbar), [Test10312.hs:41:20]), -((Test10312.hs:41:22-35,AnnLarrow), [Test10312.hs:41:24-25]), -((Test10312.hs:41:22-35,AnnVbar), [Test10312.hs:42:20]), -((Test10312.hs:42:22-42,AnnLarrow), [Test10312.hs:42:24-25]), -((Test10312.hs:42:32-42,AnnCloseP), [Test10312.hs:42:42]), -((Test10312.hs:42:32-42,AnnOpenP), [Test10312.hs:42:32]), -((Test10312.hs:(46,1)-(50,23),AnnData), [Test10312.hs:46:1-4]), -((Test10312.hs:(46,1)-(50,23),AnnEqual), [Test10312.hs:46:16]), -((Test10312.hs:(46,1)-(50,23),AnnSemi), [Test10312.hs:52:1]), -((Test10312.hs:(47,3)-(50,3),AnnCloseC), [Test10312.hs:50:3]), -((Test10312.hs:(47,3)-(50,3),AnnOpenC), [Test10312.hs:47:3]), -((Test10312.hs:47:5-23,AnnComma), [Test10312.hs:48:3]), -((Test10312.hs:47:5-23,AnnDcolon), [Test10312.hs:47:15-16]), -((Test10312.hs:48:5-22,AnnComma), [Test10312.hs:49:3]), -((Test10312.hs:48:5-22,AnnDcolon), [Test10312.hs:48:14-15]), -((Test10312.hs:49:5-20,AnnDcolon), [Test10312.hs:49:15-16]), -((Test10312.hs:50:5-23,AnnDeriving), [Test10312.hs:50:5-12]), -((Test10312.hs:50:14-23,AnnCloseP), [Test10312.hs:50:23]), -((Test10312.hs:50:14-23,AnnOpenP), [Test10312.hs:50:14]), -((Test10312.hs:50:15-18,AnnComma), [Test10312.hs:50:19]), -((Test10312.hs:52:1-22,AnnDcolon), [Test10312.hs:52:9-10]), -((Test10312.hs:52:1-22,AnnSemi), [Test10312.hs:53:1]), -((Test10312.hs:52:12-22,AnnCloseS), [Test10312.hs:52:22]), -((Test10312.hs:52:12-22,AnnOpenS), [Test10312.hs:52:12]), -((Test10312.hs:(53,1)-(59,11),AnnEqual), [Test10312.hs:53:9]), -((Test10312.hs:(53,1)-(59,11),AnnFunId), [Test10312.hs:53:1-7]), -((Test10312.hs:(53,1)-(59,11),AnnSemi), [Test10312.hs:61:1]), -((Test10312.hs:(53,11)-(59,11),AnnCloseS), [Test10312.hs:59:11]), -((Test10312.hs:(53,11)-(59,11),AnnOpenS), [Test10312.hs:53:11]), -((Test10312.hs:53:13-44,AnnComma), [Test10312.hs:54:11]), -((Test10312.hs:54:13-44,AnnComma), [Test10312.hs:55:11]), -((Test10312.hs:55:13-43,AnnComma), [Test10312.hs:56:11]), -((Test10312.hs:56:13-45,AnnComma), [Test10312.hs:57:11]), -((Test10312.hs:57:13-44,AnnComma), [Test10312.hs:58:11]), -((Test10312.hs:61:1-40,AnnDcolon), [Test10312.hs:61:8-9]), -((Test10312.hs:61:1-40,AnnSemi), [Test10312.hs:62:1]), -((Test10312.hs:61:11-13,AnnRarrow), [Test10312.hs:61:15-16]), -((Test10312.hs:61:11-40,AnnRarrow), [Test10312.hs:61:15-16]), -((Test10312.hs:61:18-28,AnnCloseS), [Test10312.hs:61:28]), -((Test10312.hs:61:18-28,AnnOpenS), [Test10312.hs:61:18]), -((Test10312.hs:61:18-28,AnnRarrow), [Test10312.hs:61:30-31]), -((Test10312.hs:61:18-40,AnnRarrow), [Test10312.hs:61:30-31]), -((Test10312.hs:61:33-40,AnnCloseS), [Test10312.hs:61:40]), -((Test10312.hs:61:33-40,AnnOpenS), [Test10312.hs:61:33]), -((Test10312.hs:(62,1)-(66,16),AnnEqual), [Test10312.hs:62:14]), -((Test10312.hs:(62,1)-(66,16),AnnFunId), [Test10312.hs:62:1-6]), -((Test10312.hs:(62,1)-(66,16),AnnSemi), [Test10312.hs:68:1]), -((Test10312.hs:(62,16)-(66,16),AnnCloseS), [Test10312.hs:66:16]), -((Test10312.hs:(62,16)-(66,16),AnnOpenS), [Test10312.hs:62:16]), -((Test10312.hs:(62,16)-(66,16),AnnVbar), [Test10312.hs:63:16]), -((Test10312.hs:62:18-33,AnnVal), [Test10312.hs:62:28-29]), -((Test10312.hs:62:18-45,AnnVal), [Test10312.hs:62:35-36]), -((Test10312.hs:63:18-30,AnnCloseC), [Test10312.hs:63:30]), -((Test10312.hs:63:18-30,AnnDotdot), [Test10312.hs:63:28-29]), -((Test10312.hs:63:18-30,AnnOpenC), [Test10312.hs:63:27]), -((Test10312.hs:63:18-37,AnnComma), [Test10312.hs:64:16]), -((Test10312.hs:63:18-37,AnnLarrow), [Test10312.hs:63:32-33]), -((Test10312.hs:(63,18)-(64,43),AnnBy), [Test10312.hs:64:32-33]), -((Test10312.hs:(63,18)-(64,43),AnnComma), [Test10312.hs:65:16]), -((Test10312.hs:(63,18)-(64,43),AnnThen), [Test10312.hs:64:18-21]), -((Test10312.hs:(63,18)-(65,28),AnnThen), [Test10312.hs:65:18-21]), -((Test10312.hs:68:1-51,AnnDcolon), [Test10312.hs:68:16-17]), -((Test10312.hs:68:1-51,AnnSemi), [Test10312.hs:69:1]), -((Test10312.hs:68:19-23,AnnDarrow), [Test10312.hs:68:25-26]), -((Test10312.hs:68:28-35,AnnCloseP), [Test10312.hs:68:35]), -((Test10312.hs:68:28-35,AnnOpenP), [Test10312.hs:68:28]), -((Test10312.hs:68:28-35,AnnRarrow), [Test10312.hs:68:37-38]), -((Test10312.hs:68:28-51,AnnRarrow), [Test10312.hs:68:37-38]), -((Test10312.hs:68:29,AnnRarrow), [Test10312.hs:68:31-32]), -((Test10312.hs:68:29-34,AnnRarrow), [Test10312.hs:68:31-32]), -((Test10312.hs:68:40-42,AnnCloseS), [Test10312.hs:68:42]), -((Test10312.hs:68:40-42,AnnOpenS), [Test10312.hs:68:40]), -((Test10312.hs:68:40-42,AnnRarrow), [Test10312.hs:68:44-45]), -((Test10312.hs:68:40-51,AnnRarrow), [Test10312.hs:68:44-45]), -((Test10312.hs:68:47-51,AnnCloseS), [Test10312.hs:68:51]), -((Test10312.hs:68:47-51,AnnOpenS), [Test10312.hs:68:47]), -((Test10312.hs:68:48-50,AnnCloseS), [Test10312.hs:68:50]), -((Test10312.hs:68:48-50,AnnOpenS), [Test10312.hs:68:48]), -((Test10312.hs:69:1-69,AnnEqual), [Test10312.hs:69:18]), -((Test10312.hs:69:1-69,AnnFunId), [Test10312.hs:69:1-14]), -((Test10312.hs:69:1-69,AnnSemi), [Test10312.hs:71:1]), -((Test10312.hs:69:20-69,AnnVal), [Test10312.hs:69:57]), -((Test10312.hs:69:27-55,AnnCloseP), [Test10312.hs:69:55]), -((Test10312.hs:69:27-55,AnnOpenP), [Test10312.hs:69:27]), -((Test10312.hs:69:38-54,AnnCloseP), [Test10312.hs:69:54]), -((Test10312.hs:69:38-54,AnnOpenP), [Test10312.hs:69:38]), -((Test10312.hs:69:39-53,AnnVal), [Test10312.hs:69:46]), -((Test10312.hs:71:1-50,AnnDcolon), [Test10312.hs:71:16-17]), -((Test10312.hs:71:1-50,AnnSemi), [Test10312.hs:72:1]), -((Test10312.hs:71:19-29,AnnCloseS), [Test10312.hs:71:29]), -((Test10312.hs:71:19-29,AnnOpenS), [Test10312.hs:71:19]), -((Test10312.hs:71:19-29,AnnRarrow), [Test10312.hs:71:31-32]), -((Test10312.hs:71:19-50,AnnRarrow), [Test10312.hs:71:31-32]), -((Test10312.hs:71:34-50,AnnCloseS), [Test10312.hs:71:50]), -((Test10312.hs:71:34-50,AnnOpenS), [Test10312.hs:71:34]), -((Test10312.hs:71:35-49,AnnCloseP), [Test10312.hs:71:49]), -((Test10312.hs:71:35-49,AnnOpenP), [Test10312.hs:71:35]), -((Test10312.hs:71:36-38,AnnComma), [Test10312.hs:71:39]), -((Test10312.hs:71:41-48,AnnCloseS), [Test10312.hs:71:48]), -((Test10312.hs:71:41-48,AnnOpenS), [Test10312.hs:71:41]), -((Test10312.hs:(72,1)-(75,22),AnnEqual), [Test10312.hs:72:20]), -((Test10312.hs:(72,1)-(75,22),AnnFunId), [Test10312.hs:72:1-14]), -((Test10312.hs:(72,1)-(75,22),AnnSemi), [Test10312.hs:77:1]), -((Test10312.hs:(72,22)-(75,22),AnnCloseS), [Test10312.hs:75:22]), -((Test10312.hs:(72,22)-(75,22),AnnOpenS), [Test10312.hs:72:22]), -((Test10312.hs:(72,22)-(75,22),AnnVbar), [Test10312.hs:73:22]), -((Test10312.hs:72:24-49,AnnCloseP), [Test10312.hs:72:49]), -((Test10312.hs:72:24-49,AnnOpenP), [Test10312.hs:72:24]), -((Test10312.hs:72:25-37,AnnComma), [Test10312.hs:72:38]), -((Test10312.hs:73:24-36,AnnCloseC), [Test10312.hs:73:36]), -((Test10312.hs:73:24-36,AnnDotdot), [Test10312.hs:73:34-35]), -((Test10312.hs:73:24-36,AnnOpenC), [Test10312.hs:73:33]), -((Test10312.hs:73:24-43,AnnComma), [Test10312.hs:74:22]), -((Test10312.hs:73:24-43,AnnLarrow), [Test10312.hs:73:38-39]), -((Test10312.hs:(73,24)-(74,67),AnnBy), [Test10312.hs:74:35-36]), -((Test10312.hs:(73,24)-(74,67),AnnGroup), [Test10312.hs:74:29-33]), -((Test10312.hs:(73,24)-(74,67),AnnThen), [Test10312.hs:74:24-27]), -((Test10312.hs:(73,24)-(74,67),AnnUsing), [Test10312.hs:74:48-52]), -((Test10312.hs:(77,1)-(79,80),AnnEqual), [Test10312.hs:77:9]), -((Test10312.hs:(77,1)-(79,80),AnnFunId), [Test10312.hs:77:1-7]), -((Test10312.hs:(77,1)-(79,80),AnnSemi), [Test10312.hs:80:1]), -((Test10312.hs:(77,11)-(79,80),AnnCloseS), [Test10312.hs:79:80]), -((Test10312.hs:(77,11)-(79,80),AnnOpenS), [Test10312.hs:77:11]), -((Test10312.hs:(77,11)-(79,80),AnnVbar), [Test10312.hs:77:32]), -((Test10312.hs:77:13-30,AnnCloseP), [Test10312.hs:77:30]), -((Test10312.hs:77:13-30,AnnOpenP), [Test10312.hs:77:13]), -((Test10312.hs:77:14,AnnComma), [Test10312.hs:77:15]), -((Test10312.hs:77:17-21,AnnComma), [Test10312.hs:77:22]), -((Test10312.hs:77:34-48,AnnCloseP), [Test10312.hs:77:48]), -((Test10312.hs:77:34-48,AnnOpenP), [Test10312.hs:77:34]), -((Test10312.hs:77:34-54,AnnComma), [Test10312.hs:78:36]), -((Test10312.hs:77:34-54,AnnLarrow), [Test10312.hs:77:50-51]), -((Test10312.hs:(77,34)-(79,78),AnnBy), [Test10312.hs:79:49-50]), -((Test10312.hs:(77,34)-(79,78),AnnGroup), [Test10312.hs:79:43-47]), -((Test10312.hs:(77,34)-(79,78),AnnThen), [Test10312.hs:79:38-41]), -((Test10312.hs:(77,34)-(79,78),AnnUsing), [Test10312.hs:79:64-68]), -((Test10312.hs:77:35,AnnComma), [Test10312.hs:77:36]), -((Test10312.hs:78:38-53,AnnComma), [Test10312.hs:79:36]), -((Test10312.hs:78:38-53,AnnLet), [Test10312.hs:78:38-40]), -((Test10312.hs:78:42-53,AnnEqual), [Test10312.hs:78:45]), -((Test10312.hs:78:42-53,AnnFunId), [Test10312.hs:78:42-43]), -((Test10312.hs:79:57-62,AnnCloseP), [Test10312.hs:79:62]), -((Test10312.hs:79:57-62,AnnOpenP), [Test10312.hs:79:57]), -((Test10312.hs:79:58,AnnComma), [Test10312.hs:79:59]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10312.hs" 80 1 diff --git a/testsuite/tests/ghc-api/annotations/T10313.stdout b/testsuite/tests/ghc-api/annotations/T10313.stdout deleted file mode 100644 index a85e849548..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10313.stdout +++ /dev/null @@ -1,13 +0,0 @@ -[([i], [(SourceText "b\x61se", base)]), - ([w], - [(SourceText "New Z3 API support is still incomplete and fragile: \ - \you may experience segmentation faults!", - New Z3 API support is still incomplete and fragile: you may experience segmentation faults!)]), - ([d], - [(SourceText "Deprecation: \ - \you may experience segmentation faults!", - Deprecation: you may experience segmentation faults!)]), - ([c], [(SourceText "foo\x63", fooc), (SourceText "b\x61r", bar)]), - ([r], [(SourceText "foo1\x67", foo1g)]), - ([s, t], [(SourceText "a\x62", ab)]), - ([s, c], [(SourceText "foo\x64", food)])] diff --git a/testsuite/tests/ghc-api/annotations/T10354.stdout b/testsuite/tests/ghc-api/annotations/T10354.stdout deleted file mode 100644 index 7fbc54d49c..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10354.stdout +++ /dev/null @@ -1,57 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10354.hs:1:1,AnnModule), [Test10354.hs:2:1-6]), -((Test10354.hs:1:1,AnnWhere), [Test10354.hs:2:18-22]), -((Test10354.hs:4:1-34,AnnDcolon), [Test10354.hs:4:3-4]), -((Test10354.hs:4:1-34,AnnSemi), [Test10354.hs:5:1]), -((Test10354.hs:4:6-16,AnnCloseP), [Test10354.hs:4:16, Test10354.hs:4:15]), -((Test10354.hs:4:6-16,AnnDarrow), [Test10354.hs:4:18-19]), -((Test10354.hs:4:6-16,AnnOpenP), [Test10354.hs:4:6, Test10354.hs:4:7]), -((Test10354.hs:4:7-15,AnnCloseP), [Test10354.hs:4:15]), -((Test10354.hs:4:7-15,AnnOpenP), [Test10354.hs:4:7]), -((Test10354.hs:4:8-11,AnnComma), [Test10354.hs:4:12]), -((Test10354.hs:4:21,AnnRarrow), [Test10354.hs:4:23-24]), -((Test10354.hs:4:21-34,AnnRarrow), [Test10354.hs:4:23-24]), -((Test10354.hs:4:26,AnnRarrow), [Test10354.hs:4:28-29]), -((Test10354.hs:4:26-34,AnnRarrow), [Test10354.hs:4:28-29]), -((Test10354.hs:5:1-14,AnnEqual), [Test10354.hs:5:7]), -((Test10354.hs:5:1-14,AnnFunId), [Test10354.hs:5:1]), -((Test10354.hs:5:1-14,AnnSemi), [Test10354.hs:7:1]), -((Test10354.hs:5:9-14,AnnVal), [Test10354.hs:5:11-12]), -((Test10354.hs:7:1-24,AnnDcolon), [Test10354.hs:7:5-6]), -((Test10354.hs:7:1-24,AnnSemi), [Test10354.hs:8:1]), -((Test10354.hs:7:8-12,AnnCloseP), [Test10354.hs:7:12, Test10354.hs:7:12]), -((Test10354.hs:7:8-12,AnnDarrow), [Test10354.hs:7:14-15]), -((Test10354.hs:7:8-12,AnnOpenP), [Test10354.hs:7:8, Test10354.hs:7:8]), -((Test10354.hs:7:8-12,AnnUnit), [Test10354.hs:7:8-12]), -((Test10354.hs:7:17,AnnRarrow), [Test10354.hs:7:18-19]), -((Test10354.hs:7:17-24,AnnRarrow), [Test10354.hs:7:18-19]), -((Test10354.hs:8:1-15,AnnEqual), [Test10354.hs:8:5]), -((Test10354.hs:8:1-15,AnnFunId), [Test10354.hs:8:1-3]), -((Test10354.hs:8:1-15,AnnSemi), [Test10354.hs:10:1]), -((Test10354.hs:10:1-23,AnnDcolon), [Test10354.hs:10:5-6]), -((Test10354.hs:10:1-23,AnnSemi), [Test10354.hs:11:1]), -((Test10354.hs:10:8,AnnDarrow), [Test10354.hs:10:10-11]), -((Test10354.hs:10:13,AnnRarrow), [Test10354.hs:10:15-16]), -((Test10354.hs:10:13-23,AnnRarrow), [Test10354.hs:10:15-16]), -((Test10354.hs:11:1-15,AnnEqual), [Test10354.hs:11:5]), -((Test10354.hs:11:1-15,AnnFunId), [Test10354.hs:11:1-3]), -((Test10354.hs:11:1-15,AnnSemi), [Test10354.hs:13:1]), -((Test10354.hs:13:1-17,AnnDcolon), [Test10354.hs:13:5-6]), -((Test10354.hs:13:1-17,AnnSemi), [Test10354.hs:14:1]), -((Test10354.hs:14:1-15,AnnEqual), [Test10354.hs:14:5]), -((Test10354.hs:14:1-15,AnnFunId), [Test10354.hs:14:1-3]), -((Test10354.hs:14:1-15,AnnSemi), [Test10354.hs:15:1]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10354.hs" 15 1 diff --git a/testsuite/tests/ghc-api/annotations/T10357.stdout b/testsuite/tests/ghc-api/annotations/T10357.stdout deleted file mode 100644 index 4810a59cd7..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10357.stdout +++ /dev/null @@ -1,64 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10357.hs:1:1,AnnModule), [Test10357.hs:2:1-6]), -((Test10357.hs:1:1,AnnWhere), [Test10357.hs:2:18-22]), -((Test10357.hs:(4,1)-(13,5),AnnEqual), [Test10357.hs:4:11]), -((Test10357.hs:(4,1)-(13,5),AnnFunId), [Test10357.hs:4:1-9]), -((Test10357.hs:(4,1)-(13,5),AnnSemi), [Test10357.hs:14:1]), -((Test10357.hs:4:13-19,AnnVal), [Test10357.hs:4:17]), -((Test10357.hs:(4,13)-(13,5),AnnVal), [Test10357.hs:4:21]), -((Test10357.hs:(5,5)-(13,5),AnnCloseS), [Test10357.hs:13:5]), -((Test10357.hs:(5,5)-(13,5),AnnOpenS), [Test10357.hs:5:5]), -((Test10357.hs:(5,5)-(13,5),AnnVbar), [Test10357.hs:10:5]), -((Test10357.hs:6:9-34,AnnCloseP), [Test10357.hs:6:34]), -((Test10357.hs:6:9-34,AnnOpenP), [Test10357.hs:6:9]), -((Test10357.hs:6:18-33,AnnCloseS), [Test10357.hs:6:33]), -((Test10357.hs:6:18-33,AnnOpenS), [Test10357.hs:6:18]), -((Test10357.hs:6:25-32,AnnCloseP), [Test10357.hs:6:32]), -((Test10357.hs:6:25-32,AnnOpenP), [Test10357.hs:6:25]), -((Test10357.hs:6:26-31,AnnVal), [Test10357.hs:6:29]), -((Test10357.hs:(7,9)-(9,9),AnnCloseP), [Test10357.hs:9:9]), -((Test10357.hs:(7,9)-(9,9),AnnOpenP), [Test10357.hs:7:9]), -((Test10357.hs:7:18-57,AnnCloseP), [Test10357.hs:7:57]), -((Test10357.hs:7:18-57,AnnOpenP), [Test10357.hs:7:18]), -((Test10357.hs:7:19-56,AnnVal), [Test10357.hs:7:43-52]), -((Test10357.hs:7:27-41,AnnCloseS), [Test10357.hs:7:41]), -((Test10357.hs:7:27-41,AnnOpenS), [Test10357.hs:7:27]), -((Test10357.hs:7:28,AnnComma), [Test10357.hs:7:29]), -((Test10357.hs:7:31-36,AnnVal), [Test10357.hs:7:33]), -((Test10357.hs:7:31-40,AnnVal), [Test10357.hs:7:38]), -((Test10357.hs:7:43-52,AnnBackquote), [Test10357.hs:7:43, Test10357.hs:7:52]), -((Test10357.hs:7:43-52,AnnVal), [Test10357.hs:7:44-51]), -((Test10357.hs:8:18-59,AnnCloseP), [Test10357.hs:8:59]), -((Test10357.hs:8:18-59,AnnOpenP), [Test10357.hs:8:18]), -((Test10357.hs:8:19-58,AnnVal), [Test10357.hs:8:43-52]), -((Test10357.hs:8:37-41,AnnCloseS), [Test10357.hs:8:41]), -((Test10357.hs:8:37-41,AnnOpenS), [Test10357.hs:8:37]), -((Test10357.hs:8:38-40,AnnMinus), [Test10357.hs:8:38]), -((Test10357.hs:8:43-52,AnnBackquote), [Test10357.hs:8:43, Test10357.hs:8:52]), -((Test10357.hs:8:43-52,AnnVal), [Test10357.hs:8:44-51]), -((Test10357.hs:10:7-20,AnnComma), [Test10357.hs:10:21]), -((Test10357.hs:10:7-20,AnnLarrow), [Test10357.hs:10:13-14]), -((Test10357.hs:10:16-20,AnnCloseS), [Test10357.hs:10:20]), -((Test10357.hs:10:16-20,AnnDotdot), [Test10357.hs:10:18-19]), -((Test10357.hs:10:16-20,AnnOpenS), [Test10357.hs:10:16]), -((Test10357.hs:10:23-44,AnnLet), [Test10357.hs:10:23-25]), -((Test10357.hs:10:23-44,AnnVbar), [Test10357.hs:11:5]), -((Test10357.hs:10:27-44,AnnEqual), [Test10357.hs:10:30]), -((Test10357.hs:10:27-44,AnnFunId), [Test10357.hs:10:27-28]), -((Test10357.hs:11:7-29,AnnLarrow), [Test10357.hs:11:13-14]), -((Test10357.hs:11:7-29,AnnVbar), [Test10357.hs:12:5]), -((Test10357.hs:12:7-24,AnnLarrow), [Test10357.hs:12:13-14]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10357.hs" 14 1 diff --git a/testsuite/tests/ghc-api/annotations/T10358.stdout b/testsuite/tests/ghc-api/annotations/T10358.stdout deleted file mode 100644 index fca1a5baa6..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10358.stdout +++ /dev/null @@ -1,40 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[(AnnBang, Test10358.hs:5:19)] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10358.hs:1:1,AnnModule), [Test10358.hs:2:1-6]), -((Test10358.hs:1:1,AnnWhere), [Test10358.hs:2:18-22]), -((Test10358.hs:(4,1)-(8,6),AnnEqual), [Test10358.hs:4:15]), -((Test10358.hs:(4,1)-(8,6),AnnFunId), [Test10358.hs:4:1-7]), -((Test10358.hs:(4,1)-(8,6),AnnSemi), [Test10358.hs:9:1]), -((Test10358.hs:(5,3)-(8,6),AnnIn), [Test10358.hs:8:3-4]), -((Test10358.hs:(5,3)-(8,6),AnnLet), [Test10358.hs:5:3-5]), -((Test10358.hs:5:7-10,AnnBang), [Test10358.hs:5:7]), -((Test10358.hs:5:7-16,AnnEqual), [Test10358.hs:5:12]), -((Test10358.hs:5:7-16,AnnFunId), [Test10358.hs:5:8-10]), -((Test10358.hs:5:7-16,AnnSemi), [Test10358.hs:5:17]), -((Test10358.hs:5:14-16,AnnVal), [Test10358.hs:5:15]), -((Test10358.hs:5:19-22,AnnBang), [Test10358.hs:5:19]), -((Test10358.hs:5:19-32,AnnEqual), [Test10358.hs:5:24]), -((Test10358.hs:5:19-32,AnnFunId), [Test10358.hs:5:20-22]), -((Test10358.hs:5:19-32,AnnSemi), [Test10358.hs:6:7]), -((Test10358.hs:5:26-32,AnnVal), [Test10358.hs:5:29]), -((Test10358.hs:6:7-16,AnnEqual), [Test10358.hs:6:10]), -((Test10358.hs:6:7-16,AnnFunId), [Test10358.hs:6:7-8]), -((Test10358.hs:6:7-16,AnnSemi), [Test10358.hs:7:7]), -((Test10358.hs:6:12-14,AnnVal), [Test10358.hs:6:13]), -((Test10358.hs:6:12-16,AnnVal), [Test10358.hs:6:15]), -((Test10358.hs:7:7-17,AnnEqual), [Test10358.hs:7:10]), -((Test10358.hs:7:7-17,AnnFunId), [Test10358.hs:7:7-8]), -((Test10358.hs:7:12-17,AnnVal), [Test10358.hs:7:14]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10358.hs" 9 1 diff --git a/testsuite/tests/ghc-api/annotations/T10396.stdout b/testsuite/tests/ghc-api/annotations/T10396.stdout deleted file mode 100644 index 32dadc3d95..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10396.stdout +++ /dev/null @@ -1,31 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10396.hs:1:1,AnnModule), [Test10396.hs:2:1-6]), -((Test10396.hs:1:1,AnnWhere), [Test10396.hs:2:18-22]), -((Test10396.hs:4:1-15,AnnDcolon), [Test10396.hs:4:8-9]), -((Test10396.hs:4:1-15,AnnSemi), [Test10396.hs:5:1]), -((Test10396.hs:4:14-15,AnnCloseP), [Test10396.hs:4:15]), -((Test10396.hs:4:14-15,AnnOpenP), [Test10396.hs:4:14]), -((Test10396.hs:(5,1)-(7,11),AnnEqual), [Test10396.hs:5:7]), -((Test10396.hs:(5,1)-(7,11),AnnFunId), [Test10396.hs:5:1-6]), -((Test10396.hs:(5,1)-(7,11),AnnSemi), [Test10396.hs:8:1]), -((Test10396.hs:(5,9)-(7,11),AnnDo), [Test10396.hs:5:9-10]), -((Test10396.hs:6:3-27,AnnLet), [Test10396.hs:6:3-5]), -((Test10396.hs:6:3-27,AnnSemi), [Test10396.hs:7:3]), -((Test10396.hs:6:7-15,AnnDcolon), [Test10396.hs:6:10-11]), -((Test10396.hs:6:7-27,AnnEqual), [Test10396.hs:6:17]), -((Test10396.hs:7:10-11,AnnCloseP), [Test10396.hs:7:11]), -((Test10396.hs:7:10-11,AnnOpenP), [Test10396.hs:7:10]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10396.hs" 8 1 diff --git a/testsuite/tests/ghc-api/annotations/T10399.stdout b/testsuite/tests/ghc-api/annotations/T10399.stdout deleted file mode 100644 index 7588393264..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10399.stdout +++ /dev/null @@ -1,89 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10399.hs:1:1,AnnModule), [Test10399.hs:8:1-6]), -((Test10399.hs:1:1,AnnWhere), [Test10399.hs:8:18-22]), -((Test10399.hs:10:1-35,AnnEqual), [Test10399.hs:10:10]), -((Test10399.hs:10:1-35,AnnSemi), [Test10399.hs:12:1]), -((Test10399.hs:10:1-35,AnnType), [Test10399.hs:10:1-4]), -((Test10399.hs:10:12-35,AnnDcolon), [Test10399.hs:10:24-25]), -((Test10399.hs:12:1-66,AnnEqual), [Test10399.hs:12:8]), -((Test10399.hs:12:1-66,AnnFunId), [Test10399.hs:12:1-6]), -((Test10399.hs:12:1-66,AnnSemi), [Test10399.hs:14:1]), -((Test10399.hs:12:10-66,AnnVal), [Test10399.hs:12:17]), -((Test10399.hs:12:23-66,AnnCloseP), [Test10399.hs:12:66]), -((Test10399.hs:12:23-66,AnnOpenP), [Test10399.hs:12:23]), -((Test10399.hs:12:24-33,AnnCloseP), [Test10399.hs:12:33]), -((Test10399.hs:12:24-33,AnnOpenP), [Test10399.hs:12:24]), -((Test10399.hs:12:24-44,AnnVal), [Test10399.hs:12:35-37]), -((Test10399.hs:12:24-54,AnnVal), [Test10399.hs:12:46-48]), -((Test10399.hs:12:24-65,AnnVal), [Test10399.hs:12:56-58]), -((Test10399.hs:12:25,AnnComma), [Test10399.hs:12:25]), -((Test10399.hs:12:26,AnnComma), [Test10399.hs:12:26]), -((Test10399.hs:12:27-28,AnnCloseP), [Test10399.hs:12:28]), -((Test10399.hs:12:27-28,AnnComma), [Test10399.hs:12:29]), -((Test10399.hs:12:27-28,AnnOpenP), [Test10399.hs:12:27]), -((Test10399.hs:12:30,AnnComma), [Test10399.hs:12:30]), -((Test10399.hs:12:31-32,AnnCloseP), [Test10399.hs:12:32]), -((Test10399.hs:12:31-32,AnnOpenP), [Test10399.hs:12:31]), -((Test10399.hs:(14,1)-(18,53),AnnData), [Test10399.hs:14:1-4]), -((Test10399.hs:(14,1)-(18,53),AnnSemi), [Test10399.hs:20:1]), -((Test10399.hs:(14,1)-(18,53),AnnWhere), [Test10399.hs:14:21-25]), -((Test10399.hs:15:5-64,AnnDcolon), [Test10399.hs:15:11-12]), -((Test10399.hs:15:5-64,AnnSemi), [Test10399.hs:16:5]), -((Test10399.hs:15:14-64,AnnDot), [Test10399.hs:15:23]), -((Test10399.hs:15:14-64,AnnForall), [Test10399.hs:15:14-19]), -((Test10399.hs:15:25-40,AnnCloseP), [Test10399.hs:15:40, Test10399.hs:15:40]), -((Test10399.hs:15:25-40,AnnDarrow), [Test10399.hs:15:42-43]), -((Test10399.hs:15:25-40,AnnOpenP), [Test10399.hs:15:25, Test10399.hs:15:25]), -((Test10399.hs:15:27-30,AnnComma), [Test10399.hs:15:31]), -((Test10399.hs:15:45-46,AnnBang), [Test10399.hs:15:45]), -((Test10399.hs:15:45-46,AnnRarrow), [Test10399.hs:15:48-49]), -((Test10399.hs:15:45-64,AnnRarrow), [Test10399.hs:15:48-49]), -((Test10399.hs:(16,5)-(17,67),AnnDcolon), [Test10399.hs:16:12-13]), -((Test10399.hs:(16,5)-(17,67),AnnSemi), [Test10399.hs:18:5]), -((Test10399.hs:(16,15)-(17,67),AnnDot), [Test10399.hs:16:25]), -((Test10399.hs:(16,15)-(17,67),AnnForall), [Test10399.hs:16:15-20]), -((Test10399.hs:16:27-42,AnnCloseP), [Test10399.hs:16:42, Test10399.hs:16:42]), -((Test10399.hs:16:27-42,AnnDarrow), [Test10399.hs:16:44-45]), -((Test10399.hs:16:27-42,AnnOpenP), [Test10399.hs:16:27, Test10399.hs:16:27]), -((Test10399.hs:16:29-32,AnnComma), [Test10399.hs:16:33]), -((Test10399.hs:16:47,AnnRarrow), [Test10399.hs:16:49-50]), -((Test10399.hs:(16,47)-(17,67),AnnRarrow), [Test10399.hs:16:49-50]), -((Test10399.hs:16:52-65,AnnRarrow), [Test10399.hs:17:44-45]), -((Test10399.hs:(16,52)-(17,67),AnnRarrow), [Test10399.hs:17:44-45]), -((Test10399.hs:17:47,AnnRarrow), [Test10399.hs:17:49-50]), -((Test10399.hs:17:47-67,AnnRarrow), [Test10399.hs:17:49-50]), -((Test10399.hs:17:65-67,AnnCloseS), [Test10399.hs:17:67]), -((Test10399.hs:17:65-67,AnnOpenS), [Test10399.hs:17:65]), -((Test10399.hs:18:5-53,AnnDcolon), [Test10399.hs:18:16-17]), -((Test10399.hs:18:19-53,AnnDot), [Test10399.hs:18:28]), -((Test10399.hs:18:19-53,AnnForall), [Test10399.hs:18:19-24]), -((Test10399.hs:18:30-35,AnnCloseP), [Test10399.hs:18:35]), -((Test10399.hs:18:30-35,AnnOpenP), [Test10399.hs:18:30]), -((Test10399.hs:18:30-35,AnnRarrow), [Test10399.hs:18:37-38]), -((Test10399.hs:18:30-53,AnnRarrow), [Test10399.hs:18:37-38]), -((Test10399.hs:20:1-25,AnnCloseQ), [Test10399.hs:20:24-25]), -((Test10399.hs:20:1-25,AnnOpen), [Test10399.hs:20:1-3]), -((Test10399.hs:20:1-25,AnnSemi), [Test10399.hs:22:1]), -((Test10399.hs:20:20-22,AnnDollar), [Test10399.hs:20:20]), -((Test10399.hs:22:1-21,AnnEqual), [Test10399.hs:22:19]), -((Test10399.hs:22:1-21,AnnFunId), [Test10399.hs:22:1-3]), -((Test10399.hs:22:1-21,AnnSemi), [Test10399.hs:23:1]), -((Test10399.hs:22:5-17,AnnDollar), [Test10399.hs:22:5]), -((Test10399.hs:22:6-17,AnnCloseP), [Test10399.hs:22:17]), -((Test10399.hs:22:6-17,AnnOpenP), [Test10399.hs:22:6]), -((Test10399.hs:22:8-15,AnnCloseQ), [Test10399.hs:22:14-15]), -((Test10399.hs:22:8-15,AnnOpen), [Test10399.hs:22:8-10]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10399.hs" 23 1 diff --git a/testsuite/tests/ghc-api/annotations/T10598.stdout b/testsuite/tests/ghc-api/annotations/T10598.stdout deleted file mode 100644 index b2d9333bf2..0000000000 --- a/testsuite/tests/ghc-api/annotations/T10598.stdout +++ /dev/null @@ -1,43 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10598.hs:1:1,AnnModule), [Test10598.hs:5:1-6]), -((Test10598.hs:1:1,AnnWhere), [Test10598.hs:5:18-22]), -((Test10598.hs:(7,1)-(9,10),AnnClass), [Test10598.hs:7:1-5]), -((Test10598.hs:(7,1)-(9,10),AnnSemi), [Test10598.hs:11:1]), -((Test10598.hs:(7,1)-(9,10),AnnWhere), [Test10598.hs:7:11-15]), -((Test10598.hs:8:3-21,AnnDcolon), [Test10598.hs:8:5-6]), -((Test10598.hs:8:3-21,AnnSemi), [Test10598.hs:9:3]), -((Test10598.hs:8:8-14,AnnRarrow), [Test10598.hs:8:16-17]), -((Test10598.hs:8:8-21,AnnRarrow), [Test10598.hs:8:16-17]), -((Test10598.hs:9:3-10,AnnEqual), [Test10598.hs:9:7]), -((Test10598.hs:9:3-10,AnnFunId), [Test10598.hs:9:3]), -((Test10598.hs:(11,1)-(12,10),AnnInstance), [Test10598.hs:11:1-8]), -((Test10598.hs:(11,1)-(12,10),AnnSemi), [Test10598.hs:14:1]), -((Test10598.hs:(11,1)-(12,10),AnnWhere), [Test10598.hs:11:16-20]), -((Test10598.hs:12:3-10,AnnEqual), [Test10598.hs:12:7]), -((Test10598.hs:12:3-10,AnnFunId), [Test10598.hs:12:3]), -((Test10598.hs:(14,1)-(17,21),AnnEqual), [Test10598.hs:14:13]), -((Test10598.hs:(14,1)-(17,21),AnnNewtype), [Test10598.hs:14:1-7]), -((Test10598.hs:(14,1)-(17,21),AnnSemi), [Test10598.hs:18:1]), -((Test10598.hs:15:3-22,AnnDeriving), [Test10598.hs:15:3-10]), -((Test10598.hs:16:3-23,AnnDeriving), [Test10598.hs:16:3-10]), -((Test10598.hs:16:12-16,AnnStock), [Test10598.hs:16:12-16]), -((Test10598.hs:17:3-21,AnnDeriving), [Test10598.hs:17:3-10]), -((Test10598.hs:17:12-19,AnnAnyclass), [Test10598.hs:17:12-19]), -((Test10598.hs:18:1-34,AnnDeriving), [Test10598.hs:18:1-8]), -((Test10598.hs:18:1-34,AnnInstance), [Test10598.hs:18:18-25]), -((Test10598.hs:18:1-34,AnnSemi), [Test10598.hs:19:1]), -((Test10598.hs:18:10-16,AnnNewtype), [Test10598.hs:18:10-16]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test10598.hs" 19 1 diff --git a/testsuite/tests/ghc-api/annotations/T11018.stdout b/testsuite/tests/ghc-api/annotations/T11018.stdout deleted file mode 100644 index 27cc80ae6f..0000000000 --- a/testsuite/tests/ghc-api/annotations/T11018.stdout +++ /dev/null @@ -1,217 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test11018.hs:1:1,AnnModule), [Test11018.hs:4:1-6]), -((Test11018.hs:1:1,AnnWhere), [Test11018.hs:4:18-22]), -((Test11018.hs:6:1-36,AnnDcolon), [Test11018.hs:6:12-13]), -((Test11018.hs:6:1-36,AnnSemi), [Test11018.hs:7:1]), -((Test11018.hs:6:15-36,AnnDot), [Test11018.hs:6:24]), -((Test11018.hs:6:15-36,AnnForall), [Test11018.hs:6:15-20]), -((Test11018.hs:6:26,AnnRarrow), [Test11018.hs:6:28-29]), -((Test11018.hs:6:26-36,AnnRarrow), [Test11018.hs:6:28-29]), -((Test11018.hs:(7,1)-(9,10),AnnEqual), [Test11018.hs:7:14]), -((Test11018.hs:(7,1)-(9,10),AnnFunId), [Test11018.hs:7:1-10]), -((Test11018.hs:(7,1)-(9,10),AnnSemi), [Test11018.hs:12:1]), -((Test11018.hs:(7,16)-(9,10),AnnDo), [Test11018.hs:7:16-17]), -((Test11018.hs:8:3-15,AnnLarrow), [Test11018.hs:8:5-6]), -((Test11018.hs:8:3-15,AnnSemi), [Test11018.hs:9:3]), -((Test11018.hs:(12,1)-(15,7),AnnCloseP), [Test11018.hs:12:32]), -((Test11018.hs:(12,1)-(15,7),AnnData), [Test11018.hs:12:1-4]), -((Test11018.hs:(12,1)-(15,7),AnnEqual), [Test11018.hs:13:5]), -((Test11018.hs:(12,1)-(15,7),AnnOpenP), [Test11018.hs:12:21]), -((Test11018.hs:(12,1)-(15,7),AnnSemi), [Test11018.hs:17:1]), -((Test11018.hs:12:21-32,AnnCloseP), [Test11018.hs:12:32]), -((Test11018.hs:12:21-32,AnnOpenP), [Test11018.hs:12:21]), -((Test11018.hs:12:22-31,AnnDcolonU), [Test11018.hs:12:24]), -((Test11018.hs:12:26,AnnRarrow), [Test11018.hs:12:28-29]), -((Test11018.hs:12:26-31,AnnRarrow), [Test11018.hs:12:28-29]), -((Test11018.hs:(13,16)-(15,7),AnnCloseC), [Test11018.hs:15:7]), -((Test11018.hs:(13,16)-(15,7),AnnOpenC), [Test11018.hs:13:16]), -((Test11018.hs:14:9-40,AnnDcolon), [Test11018.hs:14:18-19]), -((Test11018.hs:14:21-40,AnnBang), [Test11018.hs:14:21]), -((Test11018.hs:14:22-40,AnnCloseP), [Test11018.hs:14:40]), -((Test11018.hs:14:22-40,AnnOpenP), [Test11018.hs:14:22]), -((Test11018.hs:17:1-35,AnnDcolon), [Test11018.hs:17:3-4]), -((Test11018.hs:17:1-35,AnnSemi), [Test11018.hs:18:1]), -((Test11018.hs:17:6-12,AnnDarrow), [Test11018.hs:17:14-15]), -((Test11018.hs:17:19-31,AnnCloseP), [Test11018.hs:17:31]), -((Test11018.hs:17:19-31,AnnOpenP), [Test11018.hs:17:19]), -((Test11018.hs:17:20-22,AnnComma), [Test11018.hs:17:23]), -((Test11018.hs:17:24-26,AnnComma), [Test11018.hs:17:27]), -((Test11018.hs:18:1-34,AnnEqual), [Test11018.hs:18:3]), -((Test11018.hs:18:1-34,AnnFunId), [Test11018.hs:18:1]), -((Test11018.hs:18:1-34,AnnSemi), [Test11018.hs:20:1]), -((Test11018.hs:18:5-34,AnnProc), [Test11018.hs:18:5-8]), -((Test11018.hs:18:5-34,AnnRarrow), [Test11018.hs:18:18-19]), -((Test11018.hs:18:10-16,AnnCloseP), [Test11018.hs:18:16]), -((Test11018.hs:18:10-16,AnnOpenP), [Test11018.hs:18:10]), -((Test11018.hs:18:11,AnnComma), [Test11018.hs:18:12]), -((Test11018.hs:18:13,AnnComma), [Test11018.hs:18:14]), -((Test11018.hs:18:21-34,Annlarrowtail), [Test11018.hs:18:29-30]), -((Test11018.hs:18:32-34,AnnVal), [Test11018.hs:18:33]), -((Test11018.hs:20:1-36,AnnDcolon), [Test11018.hs:20:4-5]), -((Test11018.hs:20:1-36,AnnSemi), [Test11018.hs:21:1]), -((Test11018.hs:20:7-13,AnnDarrow), [Test11018.hs:20:15-16]), -((Test11018.hs:20:20-32,AnnCloseP), [Test11018.hs:20:32]), -((Test11018.hs:20:20-32,AnnOpenP), [Test11018.hs:20:20]), -((Test11018.hs:20:21-23,AnnComma), [Test11018.hs:20:24]), -((Test11018.hs:20:25-27,AnnComma), [Test11018.hs:20:28]), -((Test11018.hs:21:1-35,AnnEqual), [Test11018.hs:21:4]), -((Test11018.hs:21:1-35,AnnFunId), [Test11018.hs:21:1-2]), -((Test11018.hs:21:1-35,AnnSemi), [Test11018.hs:23:1]), -((Test11018.hs:21:6-35,AnnProc), [Test11018.hs:21:6-9]), -((Test11018.hs:21:6-35,AnnRarrow), [Test11018.hs:21:19-20]), -((Test11018.hs:21:11-17,AnnCloseP), [Test11018.hs:21:17]), -((Test11018.hs:21:11-17,AnnOpenP), [Test11018.hs:21:11]), -((Test11018.hs:21:12,AnnComma), [Test11018.hs:21:13]), -((Test11018.hs:21:14,AnnComma), [Test11018.hs:21:15]), -((Test11018.hs:21:22-35,Annrarrowtail), [Test11018.hs:21:30-31]), -((Test11018.hs:21:33-35,AnnVal), [Test11018.hs:21:34]), -((Test11018.hs:23:1-49,AnnDcolon), [Test11018.hs:23:3-4]), -((Test11018.hs:23:1-49,AnnSemi), [Test11018.hs:24:1]), -((Test11018.hs:23:6-17,AnnDarrow), [Test11018.hs:23:19-20]), -((Test11018.hs:23:22-24,AnnRarrow), [Test11018.hs:23:26-27]), -((Test11018.hs:23:22-49,AnnRarrow), [Test11018.hs:23:26-27]), -((Test11018.hs:23:31-45,AnnCloseP), [Test11018.hs:23:45]), -((Test11018.hs:23:31-45,AnnOpenP), [Test11018.hs:23:31]), -((Test11018.hs:23:32-40,AnnComma), [Test11018.hs:23:41]), -((Test11018.hs:24:1-29,AnnEqual), [Test11018.hs:24:5]), -((Test11018.hs:24:1-29,AnnFunId), [Test11018.hs:24:1]), -((Test11018.hs:24:1-29,AnnSemi), [Test11018.hs:26:1]), -((Test11018.hs:24:7-29,AnnProc), [Test11018.hs:24:7-10]), -((Test11018.hs:24:7-29,AnnRarrow), [Test11018.hs:24:18-19]), -((Test11018.hs:24:12-16,AnnCloseP), [Test11018.hs:24:16]), -((Test11018.hs:24:12-16,AnnOpenP), [Test11018.hs:24:12]), -((Test11018.hs:24:13,AnnComma), [Test11018.hs:24:14]), -((Test11018.hs:24:21-29,AnnLarrowtail), [Test11018.hs:24:23-25]), -((Test11018.hs:24:27-29,AnnVal), [Test11018.hs:24:28]), -((Test11018.hs:26:1-50,AnnDcolon), [Test11018.hs:26:4-5]), -((Test11018.hs:26:1-50,AnnSemi), [Test11018.hs:27:1]), -((Test11018.hs:26:7-18,AnnDarrow), [Test11018.hs:26:20-21]), -((Test11018.hs:26:23-25,AnnRarrow), [Test11018.hs:26:27-28]), -((Test11018.hs:26:23-50,AnnRarrow), [Test11018.hs:26:27-28]), -((Test11018.hs:26:32-46,AnnCloseP), [Test11018.hs:26:46]), -((Test11018.hs:26:32-46,AnnOpenP), [Test11018.hs:26:32]), -((Test11018.hs:26:33-41,AnnComma), [Test11018.hs:26:42]), -((Test11018.hs:27:1-30,AnnEqual), [Test11018.hs:27:6]), -((Test11018.hs:27:1-30,AnnFunId), [Test11018.hs:27:1-2]), -((Test11018.hs:27:1-30,AnnSemi), [Test11018.hs:31:1]), -((Test11018.hs:27:8-30,AnnProc), [Test11018.hs:27:8-11]), -((Test11018.hs:27:8-30,AnnRarrow), [Test11018.hs:27:19-20]), -((Test11018.hs:27:13-17,AnnCloseP), [Test11018.hs:27:17]), -((Test11018.hs:27:13-17,AnnOpenP), [Test11018.hs:27:13]), -((Test11018.hs:27:14,AnnComma), [Test11018.hs:27:15]), -((Test11018.hs:27:22-30,AnnRarrowtail), [Test11018.hs:27:24-26]), -((Test11018.hs:27:28-30,AnnVal), [Test11018.hs:27:29]), -((Test11018.hs:31:1-26,AnnDcolonU), [Test11018.hs:31:9]), -((Test11018.hs:31:1-26,AnnSemi), [Test11018.hs:32:1]), -((Test11018.hs:31:11-26,AnnDot), [Test11018.hs:31:15]), -((Test11018.hs:31:11-26,AnnForallU), [Test11018.hs:31:11]), -((Test11018.hs:31:17,AnnRarrowU), [Test11018.hs:31:19]), -((Test11018.hs:31:17-26,AnnRarrowU), [Test11018.hs:31:19]), -((Test11018.hs:(32,1)-(34,10),AnnEqual), [Test11018.hs:32:11]), -((Test11018.hs:(32,1)-(34,10),AnnFunId), [Test11018.hs:32:1-7]), -((Test11018.hs:(32,1)-(34,10),AnnSemi), [Test11018.hs:37:1]), -((Test11018.hs:(32,13)-(34,10),AnnDo), [Test11018.hs:32:13-14]), -((Test11018.hs:33:3-14,AnnLarrowU), [Test11018.hs:33:5]), -((Test11018.hs:33:3-14,AnnSemi), [Test11018.hs:34:3]), -((Test11018.hs:(37,1)-(40,7),AnnCloseP), [Test11018.hs:37:32]), -((Test11018.hs:(37,1)-(40,7),AnnData), [Test11018.hs:37:1-4]), -((Test11018.hs:(37,1)-(40,7),AnnEqual), [Test11018.hs:38:5]), -((Test11018.hs:(37,1)-(40,7),AnnOpenP), [Test11018.hs:37:22]), -((Test11018.hs:(37,1)-(40,7),AnnSemi), [Test11018.hs:42:1]), -((Test11018.hs:37:22-32,AnnCloseP), [Test11018.hs:37:32]), -((Test11018.hs:37:22-32,AnnOpenP), [Test11018.hs:37:22]), -((Test11018.hs:37:23-31,AnnDcolonU), [Test11018.hs:37:25]), -((Test11018.hs:37:27,AnnRarrowU), [Test11018.hs:37:29]), -((Test11018.hs:37:27-31,AnnRarrowU), [Test11018.hs:37:29]), -((Test11018.hs:(38,17)-(40,7),AnnCloseC), [Test11018.hs:40:7]), -((Test11018.hs:(38,17)-(40,7),AnnOpenC), [Test11018.hs:38:17]), -((Test11018.hs:39:9-40,AnnDcolonU), [Test11018.hs:39:19]), -((Test11018.hs:39:21-40,AnnBang), [Test11018.hs:39:21]), -((Test11018.hs:39:22-40,AnnCloseP), [Test11018.hs:39:40]), -((Test11018.hs:39:22-40,AnnOpenP), [Test11018.hs:39:22]), -((Test11018.hs:42:1-36,AnnDcolon), [Test11018.hs:42:4-5]), -((Test11018.hs:42:1-36,AnnSemi), [Test11018.hs:43:1]), -((Test11018.hs:42:7-13,AnnDarrowU), [Test11018.hs:42:16]), -((Test11018.hs:42:20-32,AnnCloseP), [Test11018.hs:42:32]), -((Test11018.hs:42:20-32,AnnOpenP), [Test11018.hs:42:20]), -((Test11018.hs:42:21-23,AnnComma), [Test11018.hs:42:24]), -((Test11018.hs:42:25-27,AnnComma), [Test11018.hs:42:28]), -((Test11018.hs:43:1-34,AnnEqual), [Test11018.hs:43:4]), -((Test11018.hs:43:1-34,AnnFunId), [Test11018.hs:43:1-2]), -((Test11018.hs:43:1-34,AnnSemi), [Test11018.hs:45:1]), -((Test11018.hs:43:6-34,AnnProc), [Test11018.hs:43:6-9]), -((Test11018.hs:43:6-34,AnnRarrow), [Test11018.hs:43:19-20]), -((Test11018.hs:43:11-17,AnnCloseP), [Test11018.hs:43:17]), -((Test11018.hs:43:11-17,AnnOpenP), [Test11018.hs:43:11]), -((Test11018.hs:43:12,AnnComma), [Test11018.hs:43:13]), -((Test11018.hs:43:14,AnnComma), [Test11018.hs:43:15]), -((Test11018.hs:43:22-34,AnnlarrowtailU), [Test11018.hs:43:30]), -((Test11018.hs:43:32-34,AnnVal), [Test11018.hs:43:33]), -((Test11018.hs:45:1-36,AnnDcolon), [Test11018.hs:45:5-6]), -((Test11018.hs:45:1-36,AnnSemi), [Test11018.hs:46:1]), -((Test11018.hs:45:8-14,AnnDarrowU), [Test11018.hs:45:16]), -((Test11018.hs:45:20-32,AnnCloseP), [Test11018.hs:45:32]), -((Test11018.hs:45:20-32,AnnOpenP), [Test11018.hs:45:20]), -((Test11018.hs:45:21-23,AnnComma), [Test11018.hs:45:24]), -((Test11018.hs:45:25-27,AnnComma), [Test11018.hs:45:28]), -((Test11018.hs:46:1-35,AnnEqual), [Test11018.hs:46:5]), -((Test11018.hs:46:1-35,AnnFunId), [Test11018.hs:46:1-3]), -((Test11018.hs:46:1-35,AnnSemi), [Test11018.hs:48:1]), -((Test11018.hs:46:7-35,AnnProc), [Test11018.hs:46:7-10]), -((Test11018.hs:46:7-35,AnnRarrow), [Test11018.hs:46:20-21]), -((Test11018.hs:46:12-18,AnnCloseP), [Test11018.hs:46:18]), -((Test11018.hs:46:12-18,AnnOpenP), [Test11018.hs:46:12]), -((Test11018.hs:46:13,AnnComma), [Test11018.hs:46:14]), -((Test11018.hs:46:15,AnnComma), [Test11018.hs:46:16]), -((Test11018.hs:46:23-35,AnnrarrowtailU), [Test11018.hs:46:31]), -((Test11018.hs:46:33-35,AnnVal), [Test11018.hs:46:34]), -((Test11018.hs:48:1-49,AnnDcolon), [Test11018.hs:48:4-5]), -((Test11018.hs:48:1-49,AnnSemi), [Test11018.hs:49:1]), -((Test11018.hs:48:7-18,AnnDarrowU), [Test11018.hs:48:20]), -((Test11018.hs:48:22-24,AnnRarrow), [Test11018.hs:48:26-27]), -((Test11018.hs:48:22-49,AnnRarrow), [Test11018.hs:48:26-27]), -((Test11018.hs:48:31-45,AnnCloseP), [Test11018.hs:48:45]), -((Test11018.hs:48:31-45,AnnOpenP), [Test11018.hs:48:31]), -((Test11018.hs:48:32-40,AnnComma), [Test11018.hs:48:41]), -((Test11018.hs:49:1-28,AnnEqual), [Test11018.hs:49:6]), -((Test11018.hs:49:1-28,AnnFunId), [Test11018.hs:49:1-2]), -((Test11018.hs:49:1-28,AnnSemi), [Test11018.hs:51:1]), -((Test11018.hs:49:8-28,AnnProc), [Test11018.hs:49:8-11]), -((Test11018.hs:49:8-28,AnnRarrow), [Test11018.hs:49:19-20]), -((Test11018.hs:49:13-17,AnnCloseP), [Test11018.hs:49:17]), -((Test11018.hs:49:13-17,AnnOpenP), [Test11018.hs:49:13]), -((Test11018.hs:49:14,AnnComma), [Test11018.hs:49:15]), -((Test11018.hs:49:22-28,AnnLarrowtailU), [Test11018.hs:49:24]), -((Test11018.hs:49:26-28,AnnVal), [Test11018.hs:49:27]), -((Test11018.hs:51:1-50,AnnDcolon), [Test11018.hs:51:5-6]), -((Test11018.hs:51:1-50,AnnSemi), [Test11018.hs:52:1]), -((Test11018.hs:51:8-19,AnnDarrowU), [Test11018.hs:51:21]), -((Test11018.hs:51:23-25,AnnRarrow), [Test11018.hs:51:27-28]), -((Test11018.hs:51:23-50,AnnRarrow), [Test11018.hs:51:27-28]), -((Test11018.hs:51:32-46,AnnCloseP), [Test11018.hs:51:46]), -((Test11018.hs:51:32-46,AnnOpenP), [Test11018.hs:51:32]), -((Test11018.hs:51:33-41,AnnComma), [Test11018.hs:51:42]), -((Test11018.hs:52:1-29,AnnEqual), [Test11018.hs:52:7]), -((Test11018.hs:52:1-29,AnnFunId), [Test11018.hs:52:1-3]), -((Test11018.hs:52:1-29,AnnSemi), [Test11018.hs:53:1]), -((Test11018.hs:52:9-29,AnnProc), [Test11018.hs:52:9-12]), -((Test11018.hs:52:9-29,AnnRarrow), [Test11018.hs:52:20-21]), -((Test11018.hs:52:14-18,AnnCloseP), [Test11018.hs:52:18]), -((Test11018.hs:52:14-18,AnnOpenP), [Test11018.hs:52:14]), -((Test11018.hs:52:15,AnnComma), [Test11018.hs:52:16]), -((Test11018.hs:52:23-29,AnnRarrowtailU), [Test11018.hs:52:25]), -((Test11018.hs:52:27-29,AnnVal), [Test11018.hs:52:28]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test11018.hs" 53 1 diff --git a/testsuite/tests/ghc-api/annotations/T11321.stdout b/testsuite/tests/ghc-api/annotations/T11321.stdout deleted file mode 100644 index 15d2169dba..0000000000 --- a/testsuite/tests/ghc-api/annotations/T11321.stdout +++ /dev/null @@ -1,49 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test11321.hs:1:1,AnnModule), [Test11321.hs:10:1-6]), -((Test11321.hs:1:1,AnnWhere), [Test11321.hs:10:18-22]), -((Test11321.hs:(12,1)-(17,27),AnnData), [Test11321.hs:12:1-4]), -((Test11321.hs:(12,1)-(17,27),AnnEqual), [Test11321.hs:13:3]), -((Test11321.hs:(12,1)-(17,27),AnnInstance), [Test11321.hs:12:6-13]), -((Test11321.hs:(12,1)-(17,27),AnnSemi), [Test11321.hs:18:1]), -((Test11321.hs:12:20-29,AnnCloseP), [Test11321.hs:12:29]), -((Test11321.hs:12:20-29,AnnOpenP), [Test11321.hs:12:20]), -((Test11321.hs:12:21-28,AnnDcolon), [Test11321.hs:12:23-24]), -((Test11321.hs:12:26-28,AnnCloseS), [Test11321.hs:12:28]), -((Test11321.hs:12:26-28,AnnOpenS), [Test11321.hs:12:26]), -((Test11321.hs:(13,5)-(14,8),AnnDarrow), [Test11321.hs:13:13-14]), -((Test11321.hs:(13,5)-(14,8),AnnVbar), [Test11321.hs:15:3]), -((Test11321.hs:13:9-11,AnnCloseS), [Test11321.hs:13:11]), -((Test11321.hs:13:9-11,AnnOpenS), [Test11321.hs:13:10]), -((Test11321.hs:13:9-11,AnnSimpleQuote), [Test11321.hs:13:9]), -((Test11321.hs:(15,5)-(17,27),AnnDarrow), [Test11321.hs:16:36-37]), -((Test11321.hs:(15,5)-(17,27),AnnDot), [Test11321.hs:16:22]), -((Test11321.hs:(15,5)-(17,27),AnnForall), [Test11321.hs:15:5-10]), -((Test11321.hs:15:12-19,AnnCloseP), [Test11321.hs:15:19]), -((Test11321.hs:15:12-19,AnnDcolon), [Test11321.hs:15:15-16]), -((Test11321.hs:15:12-19,AnnOpenP), [Test11321.hs:15:12]), -((Test11321.hs:16:12-21,AnnCloseP), [Test11321.hs:16:21]), -((Test11321.hs:16:12-21,AnnDcolon), [Test11321.hs:16:15-16]), -((Test11321.hs:16:12-21,AnnOpenP), [Test11321.hs:16:12]), -((Test11321.hs:16:18-20,AnnCloseS), [Test11321.hs:16:20]), -((Test11321.hs:16:18-20,AnnOpenS), [Test11321.hs:16:18]), -((Test11321.hs:16:28-30,AnnCloseP), [Test11321.hs:16:30]), -((Test11321.hs:16:28-30,AnnOpenP), [Test11321.hs:16:28]), -((Test11321.hs:16:28-30,AnnVal), [Test11321.hs:16:29]), -((Test11321.hs:17:11-18,AnnCloseP), [Test11321.hs:17:18]), -((Test11321.hs:17:11-18,AnnOpenP), [Test11321.hs:17:11]), -((Test11321.hs:17:20-27,AnnCloseP), [Test11321.hs:17:27]), -((Test11321.hs:17:20-27,AnnOpenP), [Test11321.hs:17:20]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test11321.hs" 18 1 diff --git a/testsuite/tests/ghc-api/annotations/T11332.stdout b/testsuite/tests/ghc-api/annotations/T11332.stdout deleted file mode 100644 index bdb849e680..0000000000 --- a/testsuite/tests/ghc-api/annotations/T11332.stdout +++ /dev/null @@ -1,56 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test11332.hs:1:1,AnnModule), [Test11332.hs:3:1-6]), -((Test11332.hs:1:1,AnnWhere), [Test11332.hs:3:52-56]), -((Test11332.hs:3:18-50,AnnCloseP), [Test11332.hs:3:50]), -((Test11332.hs:3:18-50,AnnOpenP), [Test11332.hs:3:18]), -((Test11332.hs:3:20-29,AnnCloseP), [Test11332.hs:3:29]), -((Test11332.hs:3:20-29,AnnComma), [Test11332.hs:3:24, Test11332.hs:3:30]), -((Test11332.hs:3:20-29,AnnDotdot), [Test11332.hs:3:22-23]), -((Test11332.hs:3:20-29,AnnOpenP), [Test11332.hs:3:21]), -((Test11332.hs:3:32-38,AnnCloseP), [Test11332.hs:3:38]), -((Test11332.hs:3:32-38,AnnComma), [Test11332.hs:3:39]), -((Test11332.hs:3:32-38,AnnDotdot), [Test11332.hs:3:36-37]), -((Test11332.hs:3:32-38,AnnOpenP), [Test11332.hs:3:33]), -((Test11332.hs:3:34,AnnComma), [Test11332.hs:3:35]), -((Test11332.hs:3:41-49,AnnCloseP), [Test11332.hs:3:49]), -((Test11332.hs:3:41-49,AnnComma), [Test11332.hs:3:47]), -((Test11332.hs:3:41-49,AnnDotdot), [Test11332.hs:3:45-46]), -((Test11332.hs:3:41-49,AnnOpenP), [Test11332.hs:3:42]), -((Test11332.hs:3:43,AnnComma), [Test11332.hs:3:44]), -((Test11332.hs:5:1-14,AnnData), [Test11332.hs:5:1-4]), -((Test11332.hs:5:1-14,AnnEqual), [Test11332.hs:5:8]), -((Test11332.hs:5:1-14,AnnSemi), [Test11332.hs:7:1]), -((Test11332.hs:5:10,AnnVbar), [Test11332.hs:5:12]), -((Test11332.hs:7:1-15,AnnEqual), [Test11332.hs:7:13]), -((Test11332.hs:7:1-15,AnnPattern), [Test11332.hs:7:1-7]), -((Test11332.hs:7:1-15,AnnSemi), [Test11332.hs:9:1]), -((Test11332.hs:9:1-14,AnnData), [Test11332.hs:9:1-4]), -((Test11332.hs:9:1-14,AnnEqual), [Test11332.hs:9:10]), -((Test11332.hs:9:1-14,AnnSemi), [Test11332.hs:11:1]), -((Test11332.hs:11:1-17,AnnEqual), [Test11332.hs:11:13]), -((Test11332.hs:11:1-17,AnnPattern), [Test11332.hs:11:1-7]), -((Test11332.hs:11:1-17,AnnSemi), [Test11332.hs:13:1]), -((Test11332.hs:13:1-14,AnnData), [Test11332.hs:13:1-4]), -((Test11332.hs:13:1-14,AnnEqual), [Test11332.hs:13:8]), -((Test11332.hs:13:1-14,AnnSemi), [Test11332.hs:15:1]), -((Test11332.hs:13:10,AnnVbar), [Test11332.hs:13:12]), -((Test11332.hs:15:1-13,AnnEqual), [Test11332.hs:15:11]), -((Test11332.hs:15:1-13,AnnPattern), [Test11332.hs:15:1-7]), -((Test11332.hs:15:1-13,AnnSemi), [Test11332.hs:17:1]), -((Test11332.hs:17:1-13,AnnEqual), [Test11332.hs:17:11]), -((Test11332.hs:17:1-13,AnnPattern), [Test11332.hs:17:1-7]), -((Test11332.hs:17:1-13,AnnSemi), [Test11332.hs:18:1]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test11332.hs" 18 1 diff --git a/testsuite/tests/ghc-api/annotations/T11430.stdout b/testsuite/tests/ghc-api/annotations/T11430.stdout deleted file mode 100644 index 528e1e3d57..0000000000 --- a/testsuite/tests/ghc-api/annotations/T11430.stdout +++ /dev/null @@ -1,5 +0,0 @@ -("f",["0x1"]) -("ib",["001"]) -("ia",["1"]) -("ia",["0x999"]) -("ia",["1"]) diff --git a/testsuite/tests/ghc-api/annotations/T12417.stdout b/testsuite/tests/ghc-api/annotations/T12417.stdout deleted file mode 100644 index 2cfd3c0635..0000000000 --- a/testsuite/tests/ghc-api/annotations/T12417.stdout +++ /dev/null @@ -1,76 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test12417.hs:1:1,AnnModule), [Test12417.hs:3:1-6]), -((Test12417.hs:1:1,AnnWhere), [Test12417.hs:3:18-22]), -((Test12417.hs:5:1-15,AnnImport), [Test12417.hs:5:1-6]), -((Test12417.hs:5:1-15,AnnSemi), [Test12417.hs:6:1]), -((Test12417.hs:6:1-16,AnnImport), [Test12417.hs:6:1-6]), -((Test12417.hs:6:1-16,AnnSemi), [Test12417.hs:8:1]), -((Test12417.hs:8:1-34,AnnImport), [Test12417.hs:8:1-6]), -((Test12417.hs:8:1-34,AnnSemi), [Test12417.hs:10:1]), -((Test12417.hs:8:19-34,AnnCloseP), [Test12417.hs:8:34]), -((Test12417.hs:8:19-34,AnnOpenP), [Test12417.hs:8:19]), -((Test12417.hs:10:1-30,AnnEqual), [Test12417.hs:10:18]), -((Test12417.hs:10:1-30,AnnSemi), [Test12417.hs:12:1]), -((Test12417.hs:10:1-30,AnnType), [Test12417.hs:10:1-4]), -((Test12417.hs:10:20-30,AnnClose), [Test12417.hs:10:29-30]), -((Test12417.hs:10:20-30,AnnOpen), [Test12417.hs:10:20-21]), -((Test12417.hs:10:23,AnnVbar), [Test12417.hs:10:25]), -((Test12417.hs:12:1-56,AnnDcolon), [Test12417.hs:12:13-14]), -((Test12417.hs:12:1-56,AnnSemi), [Test12417.hs:13:1]), -((Test12417.hs:12:16-31,AnnCloseP), [Test12417.hs:12:31, Test12417.hs:12:31]), -((Test12417.hs:12:16-31,AnnDarrow), [Test12417.hs:12:33-34]), -((Test12417.hs:12:16-31,AnnOpenP), [Test12417.hs:12:16, Test12417.hs:12:16]), -((Test12417.hs:12:17-22,AnnComma), [Test12417.hs:12:23]), -((Test12417.hs:12:36-46,AnnRarrow), [Test12417.hs:12:48-49]), -((Test12417.hs:12:36-56,AnnRarrow), [Test12417.hs:12:48-49]), -((Test12417.hs:13:1-48,AnnEqual), [Test12417.hs:13:27]), -((Test12417.hs:13:1-48,AnnFunId), [Test12417.hs:13:1-11]), -((Test12417.hs:13:1-48,AnnSemi), [Test12417.hs:14:1]), -((Test12417.hs:13:13-24,AnnClose), [Test12417.hs:13:23-24]), -((Test12417.hs:13:13-24,AnnOpen), [Test12417.hs:13:13-14]), -((Test12417.hs:13:13-24,AnnVbar), [Test12417.hs:13:21]), -((Test12417.hs:13:29-48,AnnVal), [Test12417.hs:13:37-38]), -((Test12417.hs:14:1-50,AnnEqual), [Test12417.hs:14:27]), -((Test12417.hs:14:1-50,AnnFunId), [Test12417.hs:14:1-11]), -((Test12417.hs:14:1-50,AnnSemi), [Test12417.hs:16:1]), -((Test12417.hs:14:13-25,AnnClose), [Test12417.hs:14:24-25]), -((Test12417.hs:14:13-25,AnnOpen), [Test12417.hs:14:13-14]), -((Test12417.hs:14:13-25,AnnVbar), [Test12417.hs:14:16]), -((Test12417.hs:14:29-50,AnnVal), [Test12417.hs:14:38-39]), -((Test12417.hs:16:1-75,AnnEqual), [Test12417.hs:16:8]), -((Test12417.hs:16:1-75,AnnSemi), [Test12417.hs:18:1]), -((Test12417.hs:16:1-75,AnnType), [Test12417.hs:16:1-4]), -((Test12417.hs:16:10-75,AnnClose), [Test12417.hs:16:74-75]), -((Test12417.hs:16:10-75,AnnOpen), [Test12417.hs:16:10-11]), -((Test12417.hs:16:13-15,AnnVbar), [Test12417.hs:16:17]), -((Test12417.hs:16:19-22,AnnVbar), [Test12417.hs:16:24]), -((Test12417.hs:16:26-31,AnnVbar), [Test12417.hs:16:33]), -((Test12417.hs:16:35-38,AnnVbar), [Test12417.hs:16:40]), -((Test12417.hs:16:42-56,AnnVbar), [Test12417.hs:16:58]), -((Test12417.hs:16:60-63,AnnVbar), [Test12417.hs:16:65]), -((Test12417.hs:18:1-26,AnnDcolon), [Test12417.hs:18:13-14]), -((Test12417.hs:18:1-26,AnnSemi), [Test12417.hs:19:1]), -((Test12417.hs:18:16,AnnRarrow), [Test12417.hs:18:18-19]), -((Test12417.hs:18:16-26,AnnRarrow), [Test12417.hs:18:18-19]), -((Test12417.hs:19:1-52,AnnEqual), [Test12417.hs:19:33]), -((Test12417.hs:19:1-52,AnnFunId), [Test12417.hs:19:1-11]), -((Test12417.hs:19:1-52,AnnSemi), [Test12417.hs:20:1]), -((Test12417.hs:19:13-31,AnnClose), [Test12417.hs:19:30-31]), -((Test12417.hs:19:13-31,AnnOpen), [Test12417.hs:19:13-14]), -((Test12417.hs:19:13-31,AnnVbar), [Test12417.hs:19:16, Test12417.hs:19:20, Test12417.hs:19:22, - Test12417.hs:19:24, Test12417.hs:19:26, Test12417.hs:19:28]), -((Test12417.hs:19:35-52,AnnVal), [Test12417.hs:19:44-45]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test12417.hs" 20 1 diff --git a/testsuite/tests/ghc-api/annotations/T13163.stdout b/testsuite/tests/ghc-api/annotations/T13163.stdout deleted file mode 100644 index 60b89cd832..0000000000 --- a/testsuite/tests/ghc-api/annotations/T13163.stdout +++ /dev/null @@ -1,84 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test13163.hs:1:1,AnnModule), [Test13163.hs:4:1-6]), -((Test13163.hs:1:1,AnnWhere), [Test13163.hs:8:5-9]), -((Test13163.hs:(5,3)-(8,3),AnnCloseP), [Test13163.hs:8:3]), -((Test13163.hs:(5,3)-(8,3),AnnOpenP), [Test13163.hs:5:3]), -((Test13163.hs:5:5-14,AnnCloseP), [Test13163.hs:5:14]), -((Test13163.hs:5:5-14,AnnComma), [Test13163.hs:6:3]), -((Test13163.hs:5:5-14,AnnDotdot), [Test13163.hs:5:12-13]), -((Test13163.hs:5:5-14,AnnOpenP), [Test13163.hs:5:11]), -((Test13163.hs:6:5-12,AnnType), [Test13163.hs:6:5-8]), -((Test13163.hs:6:5-16,AnnCloseP), [Test13163.hs:6:16]), -((Test13163.hs:6:5-16,AnnComma), [Test13163.hs:7:3]), -((Test13163.hs:6:5-16,AnnDotdot), [Test13163.hs:6:14-15]), -((Test13163.hs:6:5-16,AnnOpenP), [Test13163.hs:6:13]), -((Test13163.hs:6:10-12,AnnCloseP), [Test13163.hs:6:12]), -((Test13163.hs:6:10-12,AnnOpenP), [Test13163.hs:6:10]), -((Test13163.hs:6:10-12,AnnVal), [Test13163.hs:6:11]), -((Test13163.hs:7:5,AnnComma), [Test13163.hs:7:6]), -((Test13163.hs:7:8-15,AnnComma), [Test13163.hs:7:16]), -((Test13163.hs:7:8-15,AnnType), [Test13163.hs:7:8-11]), -((Test13163.hs:7:13-15,AnnCloseP), [Test13163.hs:7:15]), -((Test13163.hs:7:13-15,AnnOpenP), [Test13163.hs:7:13]), -((Test13163.hs:7:13-15,AnnVal), [Test13163.hs:7:14]), -((Test13163.hs:7:18-31,AnnPattern), [Test13163.hs:7:18-24]), -((Test13163.hs:10:1-78,AnnImport), [Test13163.hs:10:1-6]), -((Test13163.hs:10:1-78,AnnSemi), [Test13163.hs:11:1]), -((Test13163.hs:10:31-78,AnnCloseP), [Test13163.hs:10:78]), -((Test13163.hs:10:31-78,AnnOpenP), [Test13163.hs:10:31]), -((Test13163.hs:10:32-41,AnnComma), [Test13163.hs:10:42]), -((Test13163.hs:10:32-41,AnnType), [Test13163.hs:10:32-35]), -((Test13163.hs:10:37-41,AnnCloseP), [Test13163.hs:10:41]), -((Test13163.hs:10:37-41,AnnOpenP), [Test13163.hs:10:37]), -((Test13163.hs:10:37-41,AnnVal), [Test13163.hs:10:38-40]), -((Test13163.hs:10:44-53,AnnComma), [Test13163.hs:10:54]), -((Test13163.hs:10:44-53,AnnType), [Test13163.hs:10:44-47]), -((Test13163.hs:10:49-53,AnnCloseP), [Test13163.hs:10:53]), -((Test13163.hs:10:49-53,AnnOpenP), [Test13163.hs:10:49]), -((Test13163.hs:10:49-53,AnnVal), [Test13163.hs:10:50-52]), -((Test13163.hs:10:56-65,AnnComma), [Test13163.hs:10:66]), -((Test13163.hs:10:56-65,AnnType), [Test13163.hs:10:56-59]), -((Test13163.hs:10:61-65,AnnCloseP), [Test13163.hs:10:65]), -((Test13163.hs:10:61-65,AnnOpenP), [Test13163.hs:10:61]), -((Test13163.hs:10:61-65,AnnVal), [Test13163.hs:10:62-64]), -((Test13163.hs:10:68-77,AnnType), [Test13163.hs:10:68-71]), -((Test13163.hs:10:73-77,AnnCloseP), [Test13163.hs:10:77]), -((Test13163.hs:10:73-77,AnnOpenP), [Test13163.hs:10:73]), -((Test13163.hs:10:73-77,AnnVal), [Test13163.hs:10:74-76]), -((Test13163.hs:11:1-61,AnnImport), [Test13163.hs:11:1-6]), -((Test13163.hs:11:1-61,AnnSemi), [Test13163.hs:12:1]), -((Test13163.hs:11:24-61,AnnCloseP), [Test13163.hs:11:61]), -((Test13163.hs:11:24-61,AnnOpenP), [Test13163.hs:11:24]), -((Test13163.hs:11:25-31,AnnComma), [Test13163.hs:11:32]), -((Test13163.hs:11:34-44,AnnComma), [Test13163.hs:11:45]), -((Test13163.hs:11:47-56,AnnType), [Test13163.hs:11:47-50]), -((Test13163.hs:11:47-60,AnnCloseP), [Test13163.hs:11:60]), -((Test13163.hs:11:47-60,AnnDotdot), [Test13163.hs:11:58-59]), -((Test13163.hs:11:47-60,AnnOpenP), [Test13163.hs:11:57]), -((Test13163.hs:11:52-56,AnnCloseP), [Test13163.hs:11:56]), -((Test13163.hs:11:52-56,AnnOpenP), [Test13163.hs:11:52]), -((Test13163.hs:11:52-56,AnnVal), [Test13163.hs:11:53-55]), -((Test13163.hs:12:1-19,AnnImport), [Test13163.hs:12:1-6]), -((Test13163.hs:12:1-19,AnnSemi), [Test13163.hs:14:1]), -((Test13163.hs:14:1-22,AnnEqual), [Test13163.hs:14:18]), -((Test13163.hs:14:1-22,AnnPattern), [Test13163.hs:14:1-7]), -((Test13163.hs:14:1-22,AnnSemi), [Test13163.hs:16:1]), -((Test13163.hs:14:20-22,AnnCloseS), [Test13163.hs:14:22]), -((Test13163.hs:14:20-22,AnnOpenS), [Test13163.hs:14:20]), -((Test13163.hs:16:1-13,AnnEqual), [Test13163.hs:16:3]), -((Test13163.hs:16:1-13,AnnFunId), [Test13163.hs:16:1]), -((Test13163.hs:16:1-13,AnnSemi), [Test13163.hs:17:1]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test13163.hs" 17 1 diff --git a/testsuite/tests/ghc-api/annotations/T15303.stdout b/testsuite/tests/ghc-api/annotations/T15303.stdout deleted file mode 100644 index 84d592dd0e..0000000000 --- a/testsuite/tests/ghc-api/annotations/T15303.stdout +++ /dev/null @@ -1,42 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test15303.hs:4:1-4,AnnCloseP), [Test15303.hs:4:4]), -((Test15303.hs:4:1-4,AnnOpenP), [Test15303.hs:4:1]), -((Test15303.hs:4:1-4,AnnVal), [Test15303.hs:4:2-3]), -((Test15303.hs:4:1-66,AnnDcolon), [Test15303.hs:4:6-7]), -((Test15303.hs:4:1-66,AnnSemi), [Test15303.hs:5:1]), -((Test15303.hs:4:9-17,AnnDarrow), [Test15303.hs:4:19-20]), -((Test15303.hs:4:22-41,AnnRarrow), [Test15303.hs:4:43-44]), -((Test15303.hs:4:22-66,AnnRarrow), [Test15303.hs:4:43-44]), -((Test15303.hs:4:33-41,AnnCloseP), [Test15303.hs:4:41]), -((Test15303.hs:4:33-41,AnnOpenP), [Test15303.hs:4:33]), -((Test15303.hs:4:36-37,AnnSimpleQuote), [Test15303.hs:4:36]), -((Test15303.hs:4:36-37,AnnVal), [Test15303.hs:4:37]), -((Test15303.hs:4:46-48,AnnRarrow), [Test15303.hs:4:50-51]), -((Test15303.hs:4:46-66,AnnRarrow), [Test15303.hs:4:50-51]), -((Test15303.hs:4:58-66,AnnCloseP), [Test15303.hs:4:66]), -((Test15303.hs:4:58-66,AnnOpenP), [Test15303.hs:4:58]), -((Test15303.hs:4:61-62,AnnSimpleQuote), [Test15303.hs:4:61]), -((Test15303.hs:4:61-62,AnnVal), [Test15303.hs:4:62]), -((Test15303.hs:5:1-4,AnnCloseP), [Test15303.hs:5:4]), -((Test15303.hs:5:1-4,AnnOpenP), [Test15303.hs:5:1]), -((Test15303.hs:5:1-4,AnnVal), [Test15303.hs:5:2-3]), -((Test15303.hs:5:1-15,AnnEqual), [Test15303.hs:5:6]), -((Test15303.hs:5:1-15,AnnFunId), [Test15303.hs:5:1-4]), -((Test15303.hs:5:1-15,AnnSemi), [Test15303.hs:6:1]), -((Test15303.hs:6:1-11,AnnInfix), [Test15303.hs:6:1-6]), -((Test15303.hs:6:1-11,AnnSemi), [Test15303.hs:7:1]), -((Test15303.hs:6:1-11,AnnVal), [Test15303.hs:6:8]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test15303.hs" 7 1 diff --git a/testsuite/tests/ghc-api/annotations/T16212.stdout b/testsuite/tests/ghc-api/annotations/T16212.stdout deleted file mode 100644 index ec1932ed42..0000000000 --- a/testsuite/tests/ghc-api/annotations/T16212.stdout +++ /dev/null @@ -1,68 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test16212.hs:1:1,AnnModule), [Test16212.hs:1:1-6]), -((Test16212.hs:1:1,AnnWhere), [Test16212.hs:1:18-22]), -((Test16212.hs:(3,1)-(4,37),AnnClass), [Test16212.hs:3:1-5]), -((Test16212.hs:(3,1)-(4,37),AnnCloseP), [Test16212.hs:3:37]), -((Test16212.hs:(3,1)-(4,37),AnnOpenP), [Test16212.hs:3:21]), -((Test16212.hs:(3,1)-(4,37),AnnSemi), [Test16212.hs:6:1]), -((Test16212.hs:(3,1)-(4,37),AnnWhere), [Test16212.hs:3:39-43]), -((Test16212.hs:3:21-37,AnnCloseP), [Test16212.hs:3:37]), -((Test16212.hs:3:21-37,AnnOpenP), [Test16212.hs:3:21]), -((Test16212.hs:3:22-36,AnnDcolon), [Test16212.hs:3:28-29]), -((Test16212.hs:4:3-37,AnnDcolon), [Test16212.hs:4:9-10]), -((Test16212.hs:4:29-37,AnnCloseP), [Test16212.hs:4:37]), -((Test16212.hs:4:29-37,AnnOpenP), [Test16212.hs:4:29]), -((Test16212.hs:(6,1)-(7,37),AnnClass), [Test16212.hs:6:1-5]), -((Test16212.hs:(6,1)-(7,37),AnnCloseP), [Test16212.hs:6:40, Test16212.hs:6:39]), -((Test16212.hs:(6,1)-(7,37),AnnOpenP), [Test16212.hs:6:22, Test16212.hs:6:23]), -((Test16212.hs:(6,1)-(7,37),AnnSemi), [Test16212.hs:9:1]), -((Test16212.hs:(6,1)-(7,37),AnnWhere), [Test16212.hs:6:42-46]), -((Test16212.hs:6:22-40,AnnCloseP), [Test16212.hs:6:40]), -((Test16212.hs:6:22-40,AnnOpenP), [Test16212.hs:6:22]), -((Test16212.hs:6:23-39,AnnCloseP), [Test16212.hs:6:39]), -((Test16212.hs:6:23-39,AnnOpenP), [Test16212.hs:6:23]), -((Test16212.hs:6:24-38,AnnDcolon), [Test16212.hs:6:30-31]), -((Test16212.hs:7:3-37,AnnDcolon), [Test16212.hs:7:9-10]), -((Test16212.hs:7:29-37,AnnCloseP), [Test16212.hs:7:37]), -((Test16212.hs:7:29-37,AnnOpenP), [Test16212.hs:7:29]), -((Test16212.hs:(9,1)-(11,36),AnnCloseP), [Test16212.hs:9:23]), -((Test16212.hs:(9,1)-(11,36),AnnData), [Test16212.hs:9:1-4]), -((Test16212.hs:(9,1)-(11,36),AnnOpenP), [Test16212.hs:9:10]), -((Test16212.hs:(9,1)-(11,36),AnnSemi), [Test16212.hs:13:1]), -((Test16212.hs:(9,1)-(11,36),AnnWhere), [Test16212.hs:9:25-29]), -((Test16212.hs:9:10-23,AnnCloseP), [Test16212.hs:9:23]), -((Test16212.hs:9:10-23,AnnOpenP), [Test16212.hs:9:10]), -((Test16212.hs:9:11-22,AnnDcolon), [Test16212.hs:9:13-14]), -((Test16212.hs:10:5-23,AnnDcolon), [Test16212.hs:10:13-14]), -((Test16212.hs:10:5-23,AnnSemi), [Test16212.hs:11:5]), -((Test16212.hs:11:5-36,AnnDcolon), [Test16212.hs:11:13-14]), -((Test16212.hs:11:16-20,AnnRarrow), [Test16212.hs:11:22-23]), -((Test16212.hs:11:16-36,AnnRarrow), [Test16212.hs:11:22-23]), -((Test16212.hs:11:29-36,AnnCloseP), [Test16212.hs:11:36]), -((Test16212.hs:11:29-36,AnnOpenP), [Test16212.hs:11:29]), -((Test16212.hs:13:1-41,AnnCloseP), [Test16212.hs:13:12]), -((Test16212.hs:13:1-41,AnnData), [Test16212.hs:13:1-4]), -((Test16212.hs:13:1-41,AnnEqual), [Test16212.hs:13:16]), -((Test16212.hs:13:1-41,AnnOpenP), [Test16212.hs:13:10]), -((Test16212.hs:13:1-41,AnnSemi), [Test16212.hs:14:1]), -((Test16212.hs:13:10-12,AnnCloseP), [Test16212.hs:13:12]), -((Test16212.hs:13:10-12,AnnOpenP), [Test16212.hs:13:10]), -((Test16212.hs:13:22-41,AnnCloseC), [Test16212.hs:13:41]), -((Test16212.hs:13:22-41,AnnOpenC), [Test16212.hs:13:22]), -((Test16212.hs:13:24-30,AnnComma), [Test16212.hs:13:31]), -((Test16212.hs:13:24-30,AnnDcolon), [Test16212.hs:13:27-28]), -((Test16212.hs:13:33-39,AnnDcolon), [Test16212.hs:13:36-37]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test16212.hs" 14 1 diff --git a/testsuite/tests/ghc-api/annotations/T16230.stdout b/testsuite/tests/ghc-api/annotations/T16230.stdout deleted file mode 100644 index 5af52f6a50..0000000000 --- a/testsuite/tests/ghc-api/annotations/T16230.stdout +++ /dev/null @@ -1,68 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test16230.hs:1:1,AnnModule), [Test16230.hs:7:1-6]), -((Test16230.hs:1:1,AnnWhere), [Test16230.hs:7:28-32]), -((Test16230.hs:9:1-17,AnnImport), [Test16230.hs:9:1-6]), -((Test16230.hs:9:1-17,AnnSemi), [Test16230.hs:11:1]), -((Test16230.hs:11:1-11,AnnData), [Test16230.hs:11:1-4]), -((Test16230.hs:11:1-11,AnnFamily), [Test16230.hs:11:6-11]), -((Test16230.hs:11:1-11,AnnSemi), [Test16230.hs:12:1]), -((Test16230.hs:12:1-52,AnnData), [Test16230.hs:12:1-4]), -((Test16230.hs:12:1-52,AnnDot), [Test16230.hs:12:33]), -((Test16230.hs:12:1-52,AnnEqual), [Test16230.hs:12:48]), -((Test16230.hs:12:1-52,AnnForall), [Test16230.hs:12:15-20]), -((Test16230.hs:12:1-52,AnnInstance), [Test16230.hs:12:6-13]), -((Test16230.hs:12:1-52,AnnSemi), [Test16230.hs:14:1]), -((Test16230.hs:12:22-32,AnnCloseP), [Test16230.hs:12:32]), -((Test16230.hs:12:22-32,AnnDcolon), [Test16230.hs:12:25-26]), -((Test16230.hs:12:22-32,AnnOpenP), [Test16230.hs:12:22]), -((Test16230.hs:12:38-46,AnnCloseP), [Test16230.hs:12:46]), -((Test16230.hs:12:38-46,AnnOpenP), [Test16230.hs:12:38]), -((Test16230.hs:(14,1)-(15,13),AnnClass), [Test16230.hs:14:1-5]), -((Test16230.hs:(14,1)-(15,13),AnnSemi), [Test16230.hs:17:1]), -((Test16230.hs:(14,1)-(15,13),AnnWhere), [Test16230.hs:14:11-15]), -((Test16230.hs:15:3-13,AnnType), [Test16230.hs:15:3-6]), -((Test16230.hs:(17,1)-(18,31),AnnInstance), [Test16230.hs:17:1-8]), -((Test16230.hs:(17,1)-(18,31),AnnSemi), [Test16230.hs:21:1]), -((Test16230.hs:(17,1)-(18,31),AnnWhere), [Test16230.hs:17:26-30]), -((Test16230.hs:17:10-24,AnnDot), [Test16230.hs:17:18]), -((Test16230.hs:17:10-24,AnnForall), [Test16230.hs:17:10-15]), -((Test16230.hs:17:22-24,AnnCloseS), [Test16230.hs:17:24]), -((Test16230.hs:17:22-24,AnnOpenS), [Test16230.hs:17:22]), -((Test16230.hs:18:3-31,AnnDot), [Test16230.hs:18:16]), -((Test16230.hs:18:3-31,AnnEqual), [Test16230.hs:18:27]), -((Test16230.hs:18:3-31,AnnForall), [Test16230.hs:18:8-13]), -((Test16230.hs:18:3-31,AnnType), [Test16230.hs:18:3-6]), -((Test16230.hs:18:8-31,AnnDot), [Test16230.hs:18:16]), -((Test16230.hs:18:8-31,AnnEqual), [Test16230.hs:18:27]), -((Test16230.hs:18:8-31,AnnForall), [Test16230.hs:18:8-13]), -((Test16230.hs:18:21-23,AnnCloseS), [Test16230.hs:18:23]), -((Test16230.hs:18:21-23,AnnOpenS), [Test16230.hs:18:21]), -((Test16230.hs:21:1-17,AnnFamily), [Test16230.hs:21:6-11]), -((Test16230.hs:21:1-17,AnnSemi), [Test16230.hs:24:1]), -((Test16230.hs:21:1-17,AnnType), [Test16230.hs:21:1-4]), -((Test16230.hs:21:1-17,AnnWhere), [Test16230.hs:21:19-23]), -((Test16230.hs:22:3-38,AnnDot), [Test16230.hs:22:13]), -((Test16230.hs:22:3-38,AnnEqual), [Test16230.hs:22:31]), -((Test16230.hs:22:3-38,AnnForall), [Test16230.hs:22:3-8]), -((Test16230.hs:22:3-38,AnnSemi), [Test16230.hs:23:3]), -((Test16230.hs:22:17-19,AnnCloseS), [Test16230.hs:22:19]), -((Test16230.hs:22:17-19,AnnOpenS), [Test16230.hs:22:17]), -((Test16230.hs:22:21-29,AnnCloseP), [Test16230.hs:22:29]), -((Test16230.hs:22:21-29,AnnOpenP), [Test16230.hs:22:21]), -((Test16230.hs:23:3-36,AnnDot), [Test16230.hs:23:11]), -((Test16230.hs:23:3-36,AnnEqual), [Test16230.hs:23:31]), -((Test16230.hs:23:3-36,AnnForall), [Test16230.hs:23:3-8]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test16230.hs" 24 1 diff --git a/testsuite/tests/ghc-api/annotations/T16236.stdout b/testsuite/tests/ghc-api/annotations/T16236.stdout deleted file mode 100644 index 8ca1725440..0000000000 --- a/testsuite/tests/ghc-api/annotations/T16236.stdout +++ /dev/null @@ -1,87 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test16236.hs:1:1,AnnModule), [Test16236.hs:4:1-6]), -((Test16236.hs:1:1,AnnWhere), [Test16236.hs:4:22-26]), -((Test16236.hs:5:1-16,AnnImport), [Test16236.hs:5:1-6]), -((Test16236.hs:5:1-16,AnnSemi), [Test16236.hs:7:1]), -((Test16236.hs:7:1-30,AnnData), [Test16236.hs:7:1-4]), -((Test16236.hs:7:1-30,AnnEqual), [Test16236.hs:7:12]), -((Test16236.hs:7:1-30,AnnSemi), [Test16236.hs:9:1]), -((Test16236.hs:7:14-17,AnnVbar), [Test16236.hs:7:19]), -((Test16236.hs:9:1-39,AnnCloseP), [Test16236.hs:9:30]), -((Test16236.hs:9:1-39,AnnDcolon), [Test16236.hs:9:32-33]), -((Test16236.hs:9:1-39,AnnFamily), [Test16236.hs:9:6-11]), -((Test16236.hs:9:1-39,AnnOpenP), [Test16236.hs:9:20]), -((Test16236.hs:9:1-39,AnnSemi), [Test16236.hs:14:1]), -((Test16236.hs:9:1-39,AnnType), [Test16236.hs:9:1-4]), -((Test16236.hs:9:1-39,AnnWhere), [Test16236.hs:9:41-45]), -((Test16236.hs:9:20-30,AnnCloseP), [Test16236.hs:9:30]), -((Test16236.hs:9:20-30,AnnOpenP), [Test16236.hs:9:20]), -((Test16236.hs:9:21-29,AnnDcolon), [Test16236.hs:9:24-25]), -((Test16236.hs:9:27-29,AnnCloseS), [Test16236.hs:9:29]), -((Test16236.hs:9:27-29,AnnOpenS), [Test16236.hs:9:27]), -((Test16236.hs:10:3-36,AnnEqual), [Test16236.hs:10:19]), -((Test16236.hs:10:3-36,AnnSemi), [Test16236.hs:11:3]), -((Test16236.hs:10:10-17,AnnCloseP), [Test16236.hs:10:17]), -((Test16236.hs:10:10-17,AnnOpenP), [Test16236.hs:10:10]), -((Test16236.hs:10:26-36,AnnCloseP), [Test16236.hs:10:36]), -((Test16236.hs:10:26-36,AnnOpenP), [Test16236.hs:10:26]), -((Test16236.hs:11:3-24,AnnEqual), [Test16236.hs:11:19]), -((Test16236.hs:11:10-12,AnnCloseS), [Test16236.hs:11:12]), -((Test16236.hs:11:10-12,AnnOpenS), [Test16236.hs:11:11]), -((Test16236.hs:11:10-12,AnnSimpleQuote), [Test16236.hs:11:10]), -((Test16236.hs:14:1-29,AnnCloseP), [Test16236.hs:14:17]), -((Test16236.hs:14:1-29,AnnData), [Test16236.hs:14:1-4]), -((Test16236.hs:14:1-29,AnnEqual), [Test16236.hs:14:19]), -((Test16236.hs:14:1-29,AnnOpenP), [Test16236.hs:14:10]), -((Test16236.hs:14:1-29,AnnSemi), [Test16236.hs:16:1]), -((Test16236.hs:14:10-17,AnnCloseP), [Test16236.hs:14:17]), -((Test16236.hs:14:10-17,AnnOpenP), [Test16236.hs:14:10]), -((Test16236.hs:14:11-16,AnnDcolon), [Test16236.hs:14:13-14]), -((Test16236.hs:14:25-29,AnnCloseP), [Test16236.hs:14:29]), -((Test16236.hs:14:25-29,AnnOpenP), [Test16236.hs:14:25]), -((Test16236.hs:16:1-48,AnnCloseP), [Test16236.hs:16:23, Test16236.hs:16:40]), -((Test16236.hs:16:1-48,AnnDcolon), [Test16236.hs:16:42-43]), -((Test16236.hs:16:1-48,AnnFamily), [Test16236.hs:16:6-11]), -((Test16236.hs:16:1-48,AnnOpenP), [Test16236.hs:16:16, Test16236.hs:16:25]), -((Test16236.hs:16:1-48,AnnSemi), [Test16236.hs:19:1]), -((Test16236.hs:16:1-48,AnnType), [Test16236.hs:16:1-4]), -((Test16236.hs:16:1-48,AnnWhere), [Test16236.hs:16:50-54]), -((Test16236.hs:16:16-23,AnnCloseP), [Test16236.hs:16:23]), -((Test16236.hs:16:16-23,AnnOpenP), [Test16236.hs:16:16]), -((Test16236.hs:16:17-22,AnnDcolon), [Test16236.hs:16:19-20]), -((Test16236.hs:16:25-40,AnnCloseP), [Test16236.hs:16:40]), -((Test16236.hs:16:25-40,AnnOpenP), [Test16236.hs:16:25]), -((Test16236.hs:16:26-39,AnnDcolon), [Test16236.hs:16:28-29]), -((Test16236.hs:16:31,AnnRarrow), [Test16236.hs:16:33-34]), -((Test16236.hs:16:31-39,AnnRarrow), [Test16236.hs:16:33-34]), -((Test16236.hs:17:3-30,AnnEqual), [Test16236.hs:17:17]), -((Test16236.hs:19:1-11,AnnCloseP), [Test16236.hs:19:24]), -((Test16236.hs:19:1-11,AnnData), [Test16236.hs:19:1-4]), -((Test16236.hs:19:1-11,AnnFamily), [Test16236.hs:19:6-11]), -((Test16236.hs:19:1-11,AnnOpenP), [Test16236.hs:19:17]), -((Test16236.hs:19:1-11,AnnSemi), [Test16236.hs:20:1]), -((Test16236.hs:19:17-24,AnnCloseP), [Test16236.hs:19:24]), -((Test16236.hs:19:17-24,AnnOpenP), [Test16236.hs:19:17]), -((Test16236.hs:19:18-23,AnnDcolon), [Test16236.hs:19:20-21]), -((Test16236.hs:20:1-49,AnnData), [Test16236.hs:20:1-4]), -((Test16236.hs:20:1-49,AnnEqual), [Test16236.hs:20:41]), -((Test16236.hs:20:1-49,AnnInstance), [Test16236.hs:20:6-13]), -((Test16236.hs:20:1-49,AnnSemi), [Test16236.hs:21:1]), -((Test16236.hs:20:20-37,AnnCloseP), [Test16236.hs:20:37]), -((Test16236.hs:20:20-37,AnnOpenP), [Test16236.hs:20:20]), -((Test16236.hs:20:21-26,AnnRarrow), [Test16236.hs:20:28-29]), -((Test16236.hs:20:21-36,AnnRarrow), [Test16236.hs:20:28-29]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test16236.hs" 21 1 diff --git a/testsuite/tests/ghc-api/annotations/T16279.stdout b/testsuite/tests/ghc-api/annotations/T16279.stdout deleted file mode 100644 index 901c776fdd..0000000000 --- a/testsuite/tests/ghc-api/annotations/T16279.stdout +++ /dev/null @@ -1,32 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test16279.hs:5:1-20,AnnDcolon), [Test16279.hs:5:7-8]), -((Test16279.hs:5:1-20,AnnSemi), [Test16279.hs:6:1]), -((Test16279.hs:5:10-12,AnnRarrow), [Test16279.hs:5:14-15]), -((Test16279.hs:5:10-20,AnnRarrow), [Test16279.hs:5:14-15]), -((Test16279.hs:(6,1)-(7,24),AnnEqual), [Test16279.hs:6:7]), -((Test16279.hs:(6,1)-(7,24),AnnFunId), [Test16279.hs:6:1-5]), -((Test16279.hs:(6,1)-(7,24),AnnSemi), [Test16279.hs:9:1]), -((Test16279.hs:(6,9)-(7,24),AnnCase), [Test16279.hs:6:10-13]), -((Test16279.hs:(6,9)-(7,24),AnnLam), [Test16279.hs:6:9]), -((Test16279.hs:6:15-23,AnnSemi), [Test16279.hs:7:15]), -((Test16279.hs:6:17-23,AnnRarrow), [Test16279.hs:6:17-18]), -((Test16279.hs:7:17-24,AnnRarrow), [Test16279.hs:7:17-18]), -((Test16279.hs:9:1-16,AnnEqual), [Test16279.hs:9:6]), -((Test16279.hs:9:1-16,AnnFunId), [Test16279.hs:9:1-4]), -((Test16279.hs:9:1-16,AnnSemi), [Test16279.hs:11:1]), -((Test16279.hs:9:15-16,AnnCloseP), [Test16279.hs:9:16]), -((Test16279.hs:9:15-16,AnnOpenP), [Test16279.hs:9:15]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test16279.hs" 11 1 diff --git a/testsuite/tests/ghc-api/annotations/T17388.stdout b/testsuite/tests/ghc-api/annotations/T17388.stdout deleted file mode 100644 index b2012bff79..0000000000 --- a/testsuite/tests/ghc-api/annotations/T17388.stdout +++ /dev/null @@ -1,35 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test17388.hs:1:1,AnnModule), [Test17388.hs:3:1-6]), -((Test17388.hs:1:1,AnnWhere), [Test17388.hs:3:18-22]), -((Test17388.hs:5:1-21,AnnImport), [Test17388.hs:5:1-6]), -((Test17388.hs:5:1-21,AnnPackageName), [Test17388.hs:5:8-13]), -((Test17388.hs:5:1-21,AnnSemi), [Test17388.hs:6:1]), -((Test17388.hs:6:1-30,AnnClose), [Test17388.hs:6:20-22]), -((Test17388.hs:6:1-30,AnnImport), [Test17388.hs:6:1-6]), -((Test17388.hs:6:1-30,AnnOpen), [Test17388.hs:6:8-17]), -((Test17388.hs:6:1-30,AnnSemi), [Test17388.hs:8:1]), -((Test17388.hs:8:1-40,AnnClose), [Test17388.hs:8:19-21]), -((Test17388.hs:8:1-40,AnnImport), [Test17388.hs:8:1-6]), -((Test17388.hs:8:1-40,AnnOpen), [Test17388.hs:8:8-17]), -((Test17388.hs:8:1-40,AnnPackageName), [Test17388.hs:8:24-29]), -((Test17388.hs:8:1-40,AnnSemi), [Test17388.hs:9:1]), -((Test17388.hs:9:1-50,AnnClose), [Test17388.hs:9:19-21]), -((Test17388.hs:9:1-50,AnnImport), [Test17388.hs:9:1-6]), -((Test17388.hs:9:1-50,AnnOpen), [Test17388.hs:9:8-17]), -((Test17388.hs:9:1-50,AnnPackageName), [Test17388.hs:9:34-39]), -((Test17388.hs:9:1-50,AnnQualified), [Test17388.hs:9:23-31]), -((Test17388.hs:9:1-50,AnnSemi), [Test17388.hs:10:1]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test17388.hs" 10 1 diff --git a/testsuite/tests/ghc-api/annotations/T17519.stdout b/testsuite/tests/ghc-api/annotations/T17519.stdout deleted file mode 100644 index 9560a68675..0000000000 --- a/testsuite/tests/ghc-api/annotations/T17519.stdout +++ /dev/null @@ -1,27 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test17519.hs:1:1,AnnModule), [Test17519.hs:3:1-6]), -((Test17519.hs:1:1,AnnWhere), [Test17519.hs:3:18-22]), -((Test17519.hs:5:1-36,AnnDcolonU), [Test17519.hs:5:21]), -((Test17519.hs:5:1-36,AnnFamily), [Test17519.hs:5:6-11]), -((Test17519.hs:5:1-36,AnnSemi), [Test17519.hs:7:1]), -((Test17519.hs:5:1-36,AnnType), [Test17519.hs:5:1-4]), -((Test17519.hs:5:1-36,AnnWhere), [Test17519.hs:5:38-42]), -((Test17519.hs:5:23-36,AnnForallU), [Test17519.hs:5:23]), -((Test17519.hs:5:23-36,AnnRarrowU), [Test17519.hs:5:27]), -((Test17519.hs:5:29,AnnRarrowU), [Test17519.hs:5:31]), -((Test17519.hs:5:29-36,AnnRarrowU), [Test17519.hs:5:31]), -((Test17519.hs:6:3-18,AnnEqual), [Test17519.hs:6:11]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "Test17519.hs" 7 1 diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index ce95f40be2..25b3abb4b4 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -1,78 +1,3 @@ -test('annotations', [extra_files(['AnnotationLet.hs']), - normalise_slashes, - ignore_stderr], makefile_test, ['annotations']) -test('parseTree', [extra_files(['AnnotationTuple.hs']), - normalise_slashes, - ignore_stderr], makefile_test, ['parseTree']) test('comments', [extra_files(['CommentsTest.hs']), ignore_stderr], makefile_test, ['comments']) -test('exampleTest', [extra_files(['AnnotationTuple.hs']), - ignore_stderr], makefile_test, ['exampleTest']) -test('listcomps', [extra_files(['ListComprehensions.hs']), - normalise_slashes, - ignore_stderr], makefile_test, ['listcomps']) -test('T10255', [extra_files(['Test10255.hs']), - ignore_stderr], makefile_test, ['T10255']) -test('T10268', [extra_files(['Test10268.hs']), - ignore_stderr], makefile_test, ['T10268']) -test('T10269', [extra_files(['Test10269.hs']), - ignore_stderr], makefile_test, ['T10269']) -test('T10280', [extra_files(['Test10280.hs']), - ignore_stderr], makefile_test, ['T10280']) -test('T10312', [extra_files(['Test10312.hs']), - ignore_stderr], makefile_test, ['T10312']) -test('T10307', [extra_files(['Test10307.hs']), - ignore_stderr], makefile_test, ['T10307']) -test('T10309', [extra_files(['Test10309.hs']), - ignore_stderr], makefile_test, ['T10309']) -test('boolFormula', [extra_files(['TestBoolFormula.hs']), - ignore_stderr], makefile_test, ['boolFormula']) -test('T10357', [extra_files(['Test10357.hs']), - ignore_stderr], makefile_test, ['T10357']) -test('T10358', [extra_files(['Test10358.hs']), - ignore_stderr], makefile_test, ['T10358']) -test('T10278', [extra_files(['Test10278.hs']), - ignore_stderr], makefile_test, ['T10278']) -test('T10354', [extra_files(['Test10354.hs']), - ignore_stderr], makefile_test, ['T10354']) -test('T10396', [extra_files(['Test10396.hs']), - ignore_stderr], makefile_test, ['T10396']) -test('T10399', [extra_files(['Test10399.hs']), - ignore_stderr], makefile_test, ['T10399']) -test('T10313', [extra_files(['Test10313.hs', 'stringSource.hs']), - ignore_stderr], makefile_test, ['T10313']) -test('T11018', [extra_files(['Test11018.hs']), - ignore_stderr], makefile_test, ['T11018']) -test('bundle-export', [extra_files(['BundleExport.hs']), - ignore_stderr], makefile_test, ['bundle-export']) -test('T10276', [extra_files(['Test10276.hs']), - ignore_stderr], makefile_test, ['T10276']) -test('T10598', [extra_files(['Test10598.hs']), - ignore_stderr], makefile_test, ['T10598']) -test('T11321', [extra_files(['Test11321.hs']), - ignore_stderr], makefile_test, ['T11321']) -test('T11332', [extra_files(['Test11332.hs']), - ignore_stderr], makefile_test, ['T11332']) -test('T11430', [extra_files(['Test11430.hs', 't11430.hs']), - ignore_stderr], makefile_test, ['T11430']) -test('load-main', ignore_stderr, makefile_test, ['load-main']) -test('T12417', [extra_files(['Test12417.hs']), - ignore_stderr], makefile_test, ['T12417']) -test('T13163', [extra_files(['Test13163.hs']), - ignore_stderr], makefile_test, ['T13163']) -test('T15303', [extra_files(['Test15303.hs']), - ignore_stderr], makefile_test, ['T15303']) -test('T16212', [extra_files(['Test16212.hs']), - ignore_stderr], makefile_test, ['T16212']) -test('T16230', [extra_files(['Test16230.hs']), - ignore_stderr], makefile_test, ['T16230']) -test('T16236', [extra_files(['Test16236.hs']), - ignore_stderr], makefile_test, ['T16236']) -test('StarBinderAnns', [extra_files(['StarBinderAnns.hs']), - ignore_stderr], makefile_test, ['StarBinderAnns']) -test('T16279', [extra_files(['Test16279.hs']), - ignore_stderr], makefile_test, ['T16279']) -test('T17388', [extra_files(['Test17388.hs']), - ignore_stderr], makefile_test, ['T17388']) -test('T17519', [extra_files(['Test17519.hs']), - ignore_stderr], makefile_test, ['T17519']) +test('InTreeAnnotations1',normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) diff --git a/testsuite/tests/ghc-api/annotations/annotations.hs b/testsuite/tests/ghc-api/annotations/annotations.hs deleted file mode 100644 index 933170deb2..0000000000 --- a/testsuite/tests/ghc-api/annotations/annotations.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List (intercalate) -import System.IO -import GHC -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Data.Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir] <- getArgs - testOneFile libdir "AnnotationLet" - -testOneFile libdir fileName = do - p <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - t <- typecheckModule p - d <- desugarModule t - l <- loadModule d - let ts=typecheckedSource l - r =renamedSource l - -- liftIO (putStr (showSDocDebug (ppr ts))) - return (pm_annotations p) - - let anns = p - ann_items = apiAnnItems anns - ann_eof = apiAnnEofPos anns - (l,_) = fst $ head $ Map.toList ann_items - annModule = getAnnotation anns l AnnModule - annLet = getAnnotation anns l AnnLet - - putStrLn (intercalate "\n" [showAnns ann_items,pp annModule,pp annLet,pp l, - "EOF: " ++ show ann_eof]) - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPprUnsafe a diff --git a/testsuite/tests/ghc-api/annotations/annotations.stdout b/testsuite/tests/ghc-api/annotations/annotations.stdout deleted file mode 100644 index fbc028a56f..0000000000 --- a/testsuite/tests/ghc-api/annotations/annotations.stdout +++ /dev/null @@ -1,86 +0,0 @@ -[ -(AK AnnotationLet.hs:1:1 AnnCloseC = [AnnotationLet.hs:17:1]) - -(AK AnnotationLet.hs:1:1 AnnModule = [AnnotationLet.hs:2:1-6]) - -(AK AnnotationLet.hs:1:1 AnnOpenC = [AnnotationLet.hs:4:1]) - -(AK AnnotationLet.hs:1:1 AnnWhere = [AnnotationLet.hs:2:28-32]) - -(AK AnnotationLet.hs:2:22-26 AnnCloseP = [AnnotationLet.hs:2:26]) - -(AK AnnotationLet.hs:2:22-26 AnnOpenP = [AnnotationLet.hs:2:22]) - -(AK AnnotationLet.hs:5:1-32 AnnAs = [AnnotationLet.hs:5:28-29]) - -(AK AnnotationLet.hs:5:1-32 AnnImport = [AnnotationLet.hs:5:1-6]) - -(AK AnnotationLet.hs:5:1-32 AnnQualified = [AnnotationLet.hs:5:8-16]) - -(AK AnnotationLet.hs:5:1-32 AnnSemi = [AnnotationLet.hs:6:1]) - -(AK AnnotationLet.hs:(7,1)-(11,12) AnnEqual = [AnnotationLet.hs:7:5]) - -(AK AnnotationLet.hs:(7,1)-(11,12) AnnFunId = [AnnotationLet.hs:7:1-3]) - -(AK AnnotationLet.hs:(7,1)-(11,12) AnnSemi = [AnnotationLet.hs:12:1]) - -(AK AnnotationLet.hs:(7,7)-(11,12) AnnIn = [AnnotationLet.hs:11:7-8]) - -(AK AnnotationLet.hs:(7,7)-(11,12) AnnLet = [AnnotationLet.hs:7:7-9]) - -(AK AnnotationLet.hs:8:9-15 AnnEqual = [AnnotationLet.hs:8:13]) - -(AK AnnotationLet.hs:8:9-15 AnnFunId = [AnnotationLet.hs:8:9]) - -(AK AnnotationLet.hs:8:9-15 AnnSemi = [AnnotationLet.hs:9:9]) - -(AK AnnotationLet.hs:9:9-15 AnnEqual = [AnnotationLet.hs:9:13]) - -(AK AnnotationLet.hs:9:9-15 AnnFunId = [AnnotationLet.hs:9:9]) - -(AK AnnotationLet.hs:9:9-15 AnnSemi = [AnnotationLet.hs:10:9]) - -(AK AnnotationLet.hs:10:9-13 AnnEqual = [AnnotationLet.hs:10:11]) - -(AK AnnotationLet.hs:10:9-13 AnnFunId = [AnnotationLet.hs:10:9]) - -(AK AnnotationLet.hs:13:1-10 AnnInfix = [AnnotationLet.hs:13:1-6]) - -(AK AnnotationLet.hs:13:1-10 AnnSemi = [AnnotationLet.hs:14:1]) - -(AK AnnotationLet.hs:13:1-10 AnnVal = [AnnotationLet.hs:13:8]) - -(AK AnnotationLet.hs:15:1-40 AnnCloseP = [AnnotationLet.hs:15:14, AnnotationLet.hs:15:13]) - -(AK AnnotationLet.hs:15:1-40 AnnData = [AnnotationLet.hs:15:1-4]) - -(AK AnnotationLet.hs:15:1-40 AnnEqual = [AnnotationLet.hs:15:18]) - -(AK AnnotationLet.hs:15:1-40 AnnOpenP = [AnnotationLet.hs:15:6, AnnotationLet.hs:15:7]) - -(AK AnnotationLet.hs:15:1-40 AnnSemi = [AnnotationLet.hs:16:1]) - -(AK AnnotationLet.hs:15:6-14 AnnCloseP = [AnnotationLet.hs:15:14]) - -(AK AnnotationLet.hs:15:6-14 AnnOpenP = [AnnotationLet.hs:15:6]) - -(AK AnnotationLet.hs:15:7-13 AnnCloseP = [AnnotationLet.hs:15:13]) - -(AK AnnotationLet.hs:15:7-13 AnnOpenP = [AnnotationLet.hs:15:7]) - -(AK AnnotationLet.hs:15:20-28 AnnVbar = [AnnotationLet.hs:15:30]) - -(AK AnnotationLet.hs:15:24-28 AnnCloseP = [AnnotationLet.hs:15:28]) - -(AK AnnotationLet.hs:15:24-28 AnnOpenP = [AnnotationLet.hs:15:24]) - -(AK AnnotationLet.hs:15:36-40 AnnCloseP = [AnnotationLet.hs:15:40]) - -(AK AnnotationLet.hs:15:36-40 AnnOpenP = [AnnotationLet.hs:15:36]) -] - -[AnnotationLet.hs:2:1-6] -[] -AnnotationLet.hs:1:1 -EOF: Just SrcSpanPoint "./AnnotationLet.hs" 18 1 diff --git a/testsuite/tests/ghc-api/annotations/annotations.stdout-mingw32 b/testsuite/tests/ghc-api/annotations/annotations.stdout-mingw32 deleted file mode 100644 index 56f11f7f65..0000000000 --- a/testsuite/tests/ghc-api/annotations/annotations.stdout-mingw32 +++ /dev/null @@ -1,86 +0,0 @@ -[ -(AK AnnotationLet.hs:1:1 AnnCloseC = [AnnotationLet.hs:17:1]) - -(AK AnnotationLet.hs:1:1 AnnModule = [AnnotationLet.hs:2:1-6]) - -(AK AnnotationLet.hs:1:1 AnnOpenC = [AnnotationLet.hs:4:1]) - -(AK AnnotationLet.hs:1:1 AnnWhere = [AnnotationLet.hs:2:28-32]) - -(AK AnnotationLet.hs:2:22-26 AnnCloseP = [AnnotationLet.hs:2:26]) - -(AK AnnotationLet.hs:2:22-26 AnnOpenP = [AnnotationLet.hs:2:22]) - -(AK AnnotationLet.hs:5:1-32 AnnAs = [AnnotationLet.hs:5:28-29]) - -(AK AnnotationLet.hs:5:1-32 AnnImport = [AnnotationLet.hs:5:1-6]) - -(AK AnnotationLet.hs:5:1-32 AnnQualified = [AnnotationLet.hs:5:8-16]) - -(AK AnnotationLet.hs:5:1-32 AnnSemi = [AnnotationLet.hs:6:1]) - -(AK AnnotationLet.hs:(7,1)-(11,12) AnnEqual = [AnnotationLet.hs:7:5]) - -(AK AnnotationLet.hs:(7,1)-(11,12) AnnFunId = [AnnotationLet.hs:7:1-3]) - -(AK AnnotationLet.hs:(7,1)-(11,12) AnnSemi = [AnnotationLet.hs:12:1]) - -(AK AnnotationLet.hs:(7,7)-(11,12) AnnIn = [AnnotationLet.hs:11:7-8]) - -(AK AnnotationLet.hs:(7,7)-(11,12) AnnLet = [AnnotationLet.hs:7:7-9]) - -(AK AnnotationLet.hs:8:9-15 AnnEqual = [AnnotationLet.hs:8:13]) - -(AK AnnotationLet.hs:8:9-15 AnnFunId = [AnnotationLet.hs:8:9]) - -(AK AnnotationLet.hs:8:9-15 AnnSemi = [AnnotationLet.hs:9:9]) - -(AK AnnotationLet.hs:9:9-15 AnnEqual = [AnnotationLet.hs:9:13]) - -(AK AnnotationLet.hs:9:9-15 AnnFunId = [AnnotationLet.hs:9:9]) - -(AK AnnotationLet.hs:9:9-15 AnnSemi = [AnnotationLet.hs:10:9]) - -(AK AnnotationLet.hs:10:9-13 AnnEqual = [AnnotationLet.hs:10:11]) - -(AK AnnotationLet.hs:10:9-13 AnnFunId = [AnnotationLet.hs:10:9]) - -(AK AnnotationLet.hs:13:1-10 AnnInfix = [AnnotationLet.hs:13:1-6]) - -(AK AnnotationLet.hs:13:1-10 AnnSemi = [AnnotationLet.hs:14:1]) - -(AK AnnotationLet.hs:13:1-10 AnnVal = [AnnotationLet.hs:13:8]) - -(AK AnnotationLet.hs:15:1-40 AnnCloseP = [AnnotationLet.hs:15:14, AnnotationLet.hs:15:13]) - -(AK AnnotationLet.hs:15:1-40 AnnData = [AnnotationLet.hs:15:1-4]) - -(AK AnnotationLet.hs:15:1-40 AnnEqual = [AnnotationLet.hs:15:18]) - -(AK AnnotationLet.hs:15:1-40 AnnOpenP = [AnnotationLet.hs:15:6, AnnotationLet.hs:15:7]) - -(AK AnnotationLet.hs:15:1-40 AnnSemi = [AnnotationLet.hs:16:1]) - -(AK AnnotationLet.hs:15:6-14 AnnCloseP = [AnnotationLet.hs:15:14]) - -(AK AnnotationLet.hs:15:6-14 AnnOpenP = [AnnotationLet.hs:15:6]) - -(AK AnnotationLet.hs:15:7-13 AnnCloseP = [AnnotationLet.hs:15:13]) - -(AK AnnotationLet.hs:15:7-13 AnnOpenP = [AnnotationLet.hs:15:7]) - -(AK AnnotationLet.hs:15:20-28 AnnVbar = [AnnotationLet.hs:15:30]) - -(AK AnnotationLet.hs:15:24-28 AnnCloseP = [AnnotationLet.hs:15:28]) - -(AK AnnotationLet.hs:15:24-28 AnnOpenP = [AnnotationLet.hs:15:24]) - -(AK AnnotationLet.hs:15:36-40 AnnCloseP = [AnnotationLet.hs:15:40]) - -(AK AnnotationLet.hs:15:36-40 AnnOpenP = [AnnotationLet.hs:15:36]) -] - -[AnnotationLet.hs:2:1-6] -[] -AnnotationLet.hs:1:1 -EOF: Just SrcSpanPoint ".\\AnnotationLet.hs" 18 1 diff --git a/testsuite/tests/ghc-api/annotations/boolFormula.stdout b/testsuite/tests/ghc-api/annotations/boolFormula.stdout deleted file mode 100644 index 3c425811b4..0000000000 --- a/testsuite/tests/ghc-api/annotations/boolFormula.stdout +++ /dev/null @@ -1,153 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((TestBoolFormula.hs:1:1,AnnModule), [TestBoolFormula.hs:1:1-6]), -((TestBoolFormula.hs:1:1,AnnWhere), [TestBoolFormula.hs:1:24-28]), -((TestBoolFormula.hs:(3,1)-(19,9),AnnClass), [TestBoolFormula.hs:3:1-5]), -((TestBoolFormula.hs:(3,1)-(19,9),AnnSemi), [TestBoolFormula.hs:21:1]), -((TestBoolFormula.hs:(3,1)-(19,9),AnnWhere), [TestBoolFormula.hs:3:17-21]), -((TestBoolFormula.hs:4:5-25,AnnDcolon), [TestBoolFormula.hs:4:9-10]), -((TestBoolFormula.hs:4:5-25,AnnSemi), [TestBoolFormula.hs:5:5]), -((TestBoolFormula.hs:4:12,AnnRarrow), [TestBoolFormula.hs:4:14-15]), -((TestBoolFormula.hs:4:12-25,AnnRarrow), [TestBoolFormula.hs:4:14-15]), -((TestBoolFormula.hs:4:17,AnnRarrow), [TestBoolFormula.hs:4:19-20]), -((TestBoolFormula.hs:4:17-25,AnnRarrow), [TestBoolFormula.hs:4:19-20]), -((TestBoolFormula.hs:5:5-19,AnnEqual), [TestBoolFormula.hs:5:9]), -((TestBoolFormula.hs:5:5-19,AnnFunId), [TestBoolFormula.hs:5:5-7]), -((TestBoolFormula.hs:5:5-19,AnnSemi), [TestBoolFormula.hs:6:5]), -((TestBoolFormula.hs:6:5-25,AnnDcolon), [TestBoolFormula.hs:6:9-10]), -((TestBoolFormula.hs:6:5-25,AnnSemi), [TestBoolFormula.hs:7:5]), -((TestBoolFormula.hs:6:12,AnnRarrow), [TestBoolFormula.hs:6:14-15]), -((TestBoolFormula.hs:6:12-25,AnnRarrow), [TestBoolFormula.hs:6:14-15]), -((TestBoolFormula.hs:6:17,AnnRarrow), [TestBoolFormula.hs:6:19-20]), -((TestBoolFormula.hs:6:17-25,AnnRarrow), [TestBoolFormula.hs:6:19-20]), -((TestBoolFormula.hs:7:5-19,AnnEqual), [TestBoolFormula.hs:7:9]), -((TestBoolFormula.hs:7:5-19,AnnFunId), [TestBoolFormula.hs:7:5-7]), -((TestBoolFormula.hs:7:5-19,AnnSemi), [TestBoolFormula.hs:8:5]), -((TestBoolFormula.hs:8:5-25,AnnDcolon), [TestBoolFormula.hs:8:9-10]), -((TestBoolFormula.hs:8:5-25,AnnSemi), [TestBoolFormula.hs:9:5]), -((TestBoolFormula.hs:8:12,AnnRarrow), [TestBoolFormula.hs:8:14-15]), -((TestBoolFormula.hs:8:12-25,AnnRarrow), [TestBoolFormula.hs:8:14-15]), -((TestBoolFormula.hs:8:17,AnnRarrow), [TestBoolFormula.hs:8:19-20]), -((TestBoolFormula.hs:8:17-25,AnnRarrow), [TestBoolFormula.hs:8:19-20]), -((TestBoolFormula.hs:9:5-19,AnnEqual), [TestBoolFormula.hs:9:9]), -((TestBoolFormula.hs:9:5-19,AnnFunId), [TestBoolFormula.hs:9:5-7]), -((TestBoolFormula.hs:9:5-19,AnnSemi), [TestBoolFormula.hs:10:5]), -((TestBoolFormula.hs:10:5-25,AnnDcolon), [TestBoolFormula.hs:10:9-10]), -((TestBoolFormula.hs:10:5-25,AnnSemi), [TestBoolFormula.hs:11:5]), -((TestBoolFormula.hs:10:12,AnnRarrow), [TestBoolFormula.hs:10:14-15]), -((TestBoolFormula.hs:10:12-25,AnnRarrow), [TestBoolFormula.hs:10:14-15]), -((TestBoolFormula.hs:10:17,AnnRarrow), [TestBoolFormula.hs:10:19-20]), -((TestBoolFormula.hs:10:17-25,AnnRarrow), [TestBoolFormula.hs:10:19-20]), -((TestBoolFormula.hs:11:5-19,AnnEqual), [TestBoolFormula.hs:11:9]), -((TestBoolFormula.hs:11:5-19,AnnFunId), [TestBoolFormula.hs:11:5-7]), -((TestBoolFormula.hs:11:5-19,AnnSemi), [TestBoolFormula.hs:12:5]), -((TestBoolFormula.hs:12:5-25,AnnDcolon), [TestBoolFormula.hs:12:9-10]), -((TestBoolFormula.hs:12:5-25,AnnSemi), [TestBoolFormula.hs:13:5]), -((TestBoolFormula.hs:12:12,AnnRarrow), [TestBoolFormula.hs:12:14-15]), -((TestBoolFormula.hs:12:12-25,AnnRarrow), [TestBoolFormula.hs:12:14-15]), -((TestBoolFormula.hs:12:17,AnnRarrow), [TestBoolFormula.hs:12:19-20]), -((TestBoolFormula.hs:12:17-25,AnnRarrow), [TestBoolFormula.hs:12:19-20]), -((TestBoolFormula.hs:13:5-19,AnnEqual), [TestBoolFormula.hs:13:9]), -((TestBoolFormula.hs:13:5-19,AnnFunId), [TestBoolFormula.hs:13:5-7]), -((TestBoolFormula.hs:13:5-19,AnnSemi), [TestBoolFormula.hs:14:5]), -((TestBoolFormula.hs:14:5-25,AnnDcolon), [TestBoolFormula.hs:14:9-10]), -((TestBoolFormula.hs:14:5-25,AnnSemi), [TestBoolFormula.hs:15:5]), -((TestBoolFormula.hs:14:12,AnnRarrow), [TestBoolFormula.hs:14:14-15]), -((TestBoolFormula.hs:14:12-25,AnnRarrow), [TestBoolFormula.hs:14:14-15]), -((TestBoolFormula.hs:14:17,AnnRarrow), [TestBoolFormula.hs:14:19-20]), -((TestBoolFormula.hs:14:17-25,AnnRarrow), [TestBoolFormula.hs:14:19-20]), -((TestBoolFormula.hs:15:5-19,AnnEqual), [TestBoolFormula.hs:15:9]), -((TestBoolFormula.hs:15:5-19,AnnFunId), [TestBoolFormula.hs:15:5-7]), -((TestBoolFormula.hs:15:5-19,AnnSemi), [TestBoolFormula.hs:16:5]), -((TestBoolFormula.hs:(16,5)-(19,9),AnnClose), [TestBoolFormula.hs:19:7-9]), -((TestBoolFormula.hs:(16,5)-(19,9),AnnOpen), [TestBoolFormula.hs:16:5-15]), -((TestBoolFormula.hs:16:18-23,AnnCloseP), [TestBoolFormula.hs:16:23]), -((TestBoolFormula.hs:16:18-23,AnnOpenP), [TestBoolFormula.hs:16:18]), -((TestBoolFormula.hs:16:18-23,AnnVbar), [TestBoolFormula.hs:17:16]), -((TestBoolFormula.hs:17:18-31,AnnCloseP), [TestBoolFormula.hs:17:31]), -((TestBoolFormula.hs:17:18-31,AnnOpenP), [TestBoolFormula.hs:17:18]), -((TestBoolFormula.hs:17:18-31,AnnVbar), [TestBoolFormula.hs:18:16]), -((TestBoolFormula.hs:17:20-22,AnnComma), [TestBoolFormula.hs:17:26]), -((TestBoolFormula.hs:18:18-38,AnnCloseP), [TestBoolFormula.hs:18:38]), -((TestBoolFormula.hs:18:18-38,AnnOpenP), [TestBoolFormula.hs:18:18]), -((TestBoolFormula.hs:18:19-31,AnnCloseP), [TestBoolFormula.hs:18:31]), -((TestBoolFormula.hs:18:19-31,AnnComma), [TestBoolFormula.hs:18:33]), -((TestBoolFormula.hs:18:19-31,AnnOpenP), [TestBoolFormula.hs:18:19]), -((TestBoolFormula.hs:18:20-22,AnnVbar), [TestBoolFormula.hs:18:25]), -((TestBoolFormula.hs:(21,1)-(30,47),AnnClass), [TestBoolFormula.hs:21:1-5]), -((TestBoolFormula.hs:(21,1)-(30,47),AnnSemi), [TestBoolFormula.hs:32:1]), -((TestBoolFormula.hs:(21,1)-(30,47),AnnWhere), [TestBoolFormula.hs:21:13-17]), -((TestBoolFormula.hs:22:5-25,AnnDcolon), [TestBoolFormula.hs:22:9-10]), -((TestBoolFormula.hs:22:5-25,AnnSemi), [TestBoolFormula.hs:23:5]), -((TestBoolFormula.hs:22:12,AnnRarrow), [TestBoolFormula.hs:22:14-15]), -((TestBoolFormula.hs:22:12-25,AnnRarrow), [TestBoolFormula.hs:22:14-15]), -((TestBoolFormula.hs:22:17,AnnRarrow), [TestBoolFormula.hs:22:19-20]), -((TestBoolFormula.hs:22:17-25,AnnRarrow), [TestBoolFormula.hs:22:19-20]), -((TestBoolFormula.hs:23:5-25,AnnDcolon), [TestBoolFormula.hs:23:9-10]), -((TestBoolFormula.hs:23:5-25,AnnSemi), [TestBoolFormula.hs:24:5]), -((TestBoolFormula.hs:23:12,AnnRarrow), [TestBoolFormula.hs:23:14-15]), -((TestBoolFormula.hs:23:12-25,AnnRarrow), [TestBoolFormula.hs:23:14-15]), -((TestBoolFormula.hs:23:17,AnnRarrow), [TestBoolFormula.hs:23:19-20]), -((TestBoolFormula.hs:23:17-25,AnnRarrow), [TestBoolFormula.hs:23:19-20]), -((TestBoolFormula.hs:24:5-25,AnnDcolon), [TestBoolFormula.hs:24:9-10]), -((TestBoolFormula.hs:24:5-25,AnnSemi), [TestBoolFormula.hs:25:5]), -((TestBoolFormula.hs:24:12,AnnRarrow), [TestBoolFormula.hs:24:14-15]), -((TestBoolFormula.hs:24:12-25,AnnRarrow), [TestBoolFormula.hs:24:14-15]), -((TestBoolFormula.hs:24:17,AnnRarrow), [TestBoolFormula.hs:24:19-20]), -((TestBoolFormula.hs:24:17-25,AnnRarrow), [TestBoolFormula.hs:24:19-20]), -((TestBoolFormula.hs:25:5-19,AnnEqual), [TestBoolFormula.hs:25:9]), -((TestBoolFormula.hs:25:5-19,AnnFunId), [TestBoolFormula.hs:25:5-7]), -((TestBoolFormula.hs:25:5-19,AnnSemi), [TestBoolFormula.hs:26:5]), -((TestBoolFormula.hs:26:5-25,AnnDcolon), [TestBoolFormula.hs:26:9-10]), -((TestBoolFormula.hs:26:5-25,AnnSemi), [TestBoolFormula.hs:27:5]), -((TestBoolFormula.hs:26:12,AnnRarrow), [TestBoolFormula.hs:26:14-15]), -((TestBoolFormula.hs:26:12-25,AnnRarrow), [TestBoolFormula.hs:26:14-15]), -((TestBoolFormula.hs:26:17,AnnRarrow), [TestBoolFormula.hs:26:19-20]), -((TestBoolFormula.hs:26:17-25,AnnRarrow), [TestBoolFormula.hs:26:19-20]), -((TestBoolFormula.hs:27:5-19,AnnEqual), [TestBoolFormula.hs:27:9]), -((TestBoolFormula.hs:27:5-19,AnnFunId), [TestBoolFormula.hs:27:5-7]), -((TestBoolFormula.hs:27:5-19,AnnSemi), [TestBoolFormula.hs:28:5]), -((TestBoolFormula.hs:28:5-26,AnnDcolon), [TestBoolFormula.hs:28:10-11]), -((TestBoolFormula.hs:28:5-26,AnnSemi), [TestBoolFormula.hs:29:5]), -((TestBoolFormula.hs:28:13,AnnRarrow), [TestBoolFormula.hs:28:15-16]), -((TestBoolFormula.hs:28:13-26,AnnRarrow), [TestBoolFormula.hs:28:15-16]), -((TestBoolFormula.hs:28:18,AnnRarrow), [TestBoolFormula.hs:28:20-21]), -((TestBoolFormula.hs:28:18-26,AnnRarrow), [TestBoolFormula.hs:28:20-21]), -((TestBoolFormula.hs:29:5-20,AnnEqual), [TestBoolFormula.hs:29:10]), -((TestBoolFormula.hs:29:5-20,AnnFunId), [TestBoolFormula.hs:29:5-8]), -((TestBoolFormula.hs:29:5-20,AnnSemi), [TestBoolFormula.hs:30:5]), -((TestBoolFormula.hs:30:5-47,AnnClose), [TestBoolFormula.hs:30:45-47]), -((TestBoolFormula.hs:30:5-47,AnnOpen), [TestBoolFormula.hs:30:5-15]), -((TestBoolFormula.hs:30:17-19,AnnComma), [TestBoolFormula.hs:30:20]), -((TestBoolFormula.hs:30:22-43,AnnCloseP), [TestBoolFormula.hs:30:43]), -((TestBoolFormula.hs:30:22-43,AnnOpenP), [TestBoolFormula.hs:30:22]), -((TestBoolFormula.hs:30:23-25,AnnComma), [TestBoolFormula.hs:30:26]), -((TestBoolFormula.hs:30:23-30,AnnVbar), [TestBoolFormula.hs:30:32]), -((TestBoolFormula.hs:30:34-36,AnnComma), [TestBoolFormula.hs:30:37]), -((TestBoolFormula.hs:(32,1)-(36,19),AnnInstance), [TestBoolFormula.hs:32:1-8]), -((TestBoolFormula.hs:(32,1)-(36,19),AnnSemi), [TestBoolFormula.hs:37:1]), -((TestBoolFormula.hs:(32,1)-(36,19),AnnWhere), [TestBoolFormula.hs:32:18-22]), -((TestBoolFormula.hs:33:5-19,AnnEqual), [TestBoolFormula.hs:33:9]), -((TestBoolFormula.hs:33:5-19,AnnFunId), [TestBoolFormula.hs:33:5-7]), -((TestBoolFormula.hs:33:5-19,AnnSemi), [TestBoolFormula.hs:34:5]), -((TestBoolFormula.hs:34:5-19,AnnEqual), [TestBoolFormula.hs:34:9]), -((TestBoolFormula.hs:34:5-19,AnnFunId), [TestBoolFormula.hs:34:5-7]), -((TestBoolFormula.hs:34:5-19,AnnSemi), [TestBoolFormula.hs:35:5]), -((TestBoolFormula.hs:35:5-20,AnnEqual), [TestBoolFormula.hs:35:10]), -((TestBoolFormula.hs:35:5-20,AnnFunId), [TestBoolFormula.hs:35:5-8]), -((TestBoolFormula.hs:35:5-20,AnnSemi), [TestBoolFormula.hs:36:5]), -((TestBoolFormula.hs:36:5-19,AnnEqual), [TestBoolFormula.hs:36:9]), -((TestBoolFormula.hs:36:5-19,AnnFunId), [TestBoolFormula.hs:36:5-7]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "TestBoolFormula.hs" 37 1 diff --git a/testsuite/tests/ghc-api/annotations/comments.hs b/testsuite/tests/ghc-api/annotations/comments.hs index 8497c87eda..d8c68594d0 100644 --- a/testsuite/tests/ghc-api/annotations/comments.hs +++ b/testsuite/tests/ghc-api/annotations/comments.hs @@ -50,7 +50,8 @@ testOneFile libdir fileName useHaddock = do return (pm_annotations p) let anns = p - ann_comments = apiAnnComments anns + -- ann_comments = apiAnnComments anns + ann_comments = Map.empty ann_rcomments = apiAnnRogueComments anns comments = map (\(s,v) -> (RealSrcSpan s Nothing, v)) (Map.toList ann_comments) diff --git a/testsuite/tests/ghc-api/annotations/comments.stdout b/testsuite/tests/ghc-api/annotations/comments.stdout index e5ff216fb0..1b7ed7061a 100644 --- a/testsuite/tests/ghc-api/annotations/comments.stdout +++ b/testsuite/tests/ghc-api/annotations/comments.stdout @@ -1,24 +1,17 @@ [ -( CommentsTest.hs:(12,7)-(15,14) = -[(CommentsTest.hs:14:15-24,AnnLineComment "-- value 2")]) - ( <no location info> = -[(CommentsTest.hs:11:1-33,AnnDocCommentNext " The function @foo@ does blah"), +[(Anchor CommentsTest.hs:11:1-33 UnchangedAnchor,AnnComment {ac_tok = AnnDocCommentNext " The function @foo@ does blah", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 9 31 33}), -(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}"), +(Anchor CommentsTest.hs:(3,1)-(7,2) UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 2 27 32}), -(CommentsTest.hs:1:1-31,AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}")]) +(Anchor CommentsTest.hs:1:1-31 UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}", ac_prior_tok = SrcSpanPoint "./CommentsTest.hs" 1 1})]) ] [ -( CommentsTest.hs:(12,7)-(15,14) = -[(CommentsTest.hs:14:15-24,AnnLineComment "-- value 2")]) - ( <no location info> = -[(CommentsTest.hs:11:1-33,AnnLineComment "-- | The function @foo@ does blah"), +[(Anchor CommentsTest.hs:11:1-33 UnchangedAnchor,AnnComment {ac_tok = AnnLineComment "-- | The function @foo@ does blah", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 9 31 33}), -(CommentsTest.hs:(3,1)-(7,2),AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}"), +(Anchor CommentsTest.hs:(3,1)-(7,2) UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-\nAn opening comment\n {- with a nested one -}\n {-# nested PRAGMA #-}\n-}", ac_prior_tok = SrcSpanOneLine "./CommentsTest.hs" 2 27 32}), -(CommentsTest.hs:1:1-31,AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}")]) +(Anchor CommentsTest.hs:1:1-31 UnchangedAnchor,AnnComment {ac_tok = AnnBlockComment "{-# LANGUAGE DeriveFoldable #-}", ac_prior_tok = SrcSpanPoint "./CommentsTest.hs" 1 1})]) ] - diff --git a/testsuite/tests/ghc-api/annotations/listcomps.hs b/testsuite/tests/ghc-api/annotations/listcomps.hs deleted file mode 100644 index 115aef6527..0000000000 --- a/testsuite/tests/ghc-api/annotations/listcomps.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List (intercalate) -import System.IO -import GHC -import GHC.Types.Basic -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Parser.Annotation -import GHC.Data.Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import System.Exit -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir] <- getArgs - testOneFile libdir "ListComprehensions" - exitSuccess - -testOneFile libdir fileName = do - p <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - t <- typecheckModule p - d <- desugarModule t - l <- loadModule d - return p - - let anns = pm_annotations p - ann_items = apiAnnItems anns - ann_eof = apiAnnEofPos anns - let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) - - putStrLn (pp spans) - putStrLn "--------------------------------" - putStrLn (intercalate "\n" [showAnns ann_items,"EOF: " ++ show ann_eof]) - - where - getAnnSrcSpans :: ApiAnns -> [(RealSrcSpan,(ApiAnnKey,[RealSrcSpan]))] - getAnnSrcSpans anns = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList (apiAnnItems anns) - - getAllSrcSpans :: (Data t) => t -> [RealSrcSpan] - getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [RealSrcSpan] - getSrcSpan (RealSrcSpan ss _) = [ss] - getSrcSpan (UnhelpfulSpan _) = [] - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPprUnsafe a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/testsuite/tests/ghc-api/annotations/listcomps.stdout b/testsuite/tests/ghc-api/annotations/listcomps.stdout deleted file mode 100644 index 169a1f6634..0000000000 --- a/testsuite/tests/ghc-api/annotations/listcomps.stdout +++ /dev/null @@ -1,160 +0,0 @@ -{ListComprehensions.hs:1:1, ListComprehensions.hs:6:8-25, - ListComprehensions.hs:10:1-15, ListComprehensions.hs:10:8-15, - ListComprehensions.hs:11:1-30, ListComprehensions.hs:11:18-25, - ListComprehensions.hs:11:30, ListComprehensions.hs:12:1-27, - ListComprehensions.hs:12:8-15, ListComprehensions.hs:12:17-27, - ListComprehensions.hs:12:18-26, ListComprehensions.hs:13:1-25, - ListComprehensions.hs:13:8-16, ListComprehensions.hs:13:18-25, - ListComprehensions.hs:13:19-24, ListComprehensions.hs:17:1-16, - ListComprehensions.hs:17:1-25, ListComprehensions.hs:17:21-25, - ListComprehensions.hs:17:22-24, ListComprehensions.hs:18:1-16, - ListComprehensions.hs:(18,1)-(22,20), - ListComprehensions.hs:(18,18)-(22,20), - ListComprehensions.hs:(18,20)-(22,20), ListComprehensions.hs:18:22, - ListComprehensions.hs:18:22-26, ListComprehensions.hs:18:22-30, - ListComprehensions.hs:(18,22)-(21,34), ListComprehensions.hs:18:24, - ListComprehensions.hs:18:26, ListComprehensions.hs:18:28, - ListComprehensions.hs:18:30, ListComprehensions.hs:19:22, - ListComprehensions.hs:19:22-33, - ListComprehensions.hs:(19,22)-(21,34), - ListComprehensions.hs:19:27-33, ListComprehensions.hs:19:28, - ListComprehensions.hs:19:31-32, ListComprehensions.hs:20:22, - ListComprehensions.hs:20:22-34, ListComprehensions.hs:20:27-34, - ListComprehensions.hs:20:28-29, ListComprehensions.hs:20:32-33, - ListComprehensions.hs:21:22, ListComprehensions.hs:21:22-34, - ListComprehensions.hs:21:27-34, ListComprehensions.hs:21:28-29, - ListComprehensions.hs:21:32-33, ListComprehensions.hs:24:1-6, - ListComprehensions.hs:24:1-27, ListComprehensions.hs:24:11-15, - ListComprehensions.hs:24:11-27, ListComprehensions.hs:24:12-14, - ListComprehensions.hs:24:20-27, ListComprehensions.hs:24:21-26, - ListComprehensions.hs:25:1-6, ListComprehensions.hs:(25,1)-(28,14), - ListComprehensions.hs:25:8-10, - ListComprehensions.hs:(25,12)-(28,14), - ListComprehensions.hs:(25,14)-(28,14), - ListComprehensions.hs:25:16-20, - ListComprehensions.hs:(25,16)-(27,22), ListComprehensions.hs:26:16, - ListComprehensions.hs:26:16-23, - ListComprehensions.hs:(26,16)-(27,22), - ListComprehensions.hs:26:21-23, ListComprehensions.hs:27:21-22} --------------------------------- -[ -(AK ListComprehensions.hs:1:1 AnnModule = [ListComprehensions.hs:6:1-6]) - -(AK ListComprehensions.hs:1:1 AnnWhere = [ListComprehensions.hs:6:27-31]) - -(AK ListComprehensions.hs:10:1-15 AnnImport = [ListComprehensions.hs:10:1-6]) - -(AK ListComprehensions.hs:10:1-15 AnnSemi = [ListComprehensions.hs:11:1]) - -(AK ListComprehensions.hs:11:1-30 AnnAs = [ListComprehensions.hs:11:27-28]) - -(AK ListComprehensions.hs:11:1-30 AnnImport = [ListComprehensions.hs:11:1-6]) - -(AK ListComprehensions.hs:11:1-30 AnnQualified = [ListComprehensions.hs:11:8-16]) - -(AK ListComprehensions.hs:11:1-30 AnnSemi = [ListComprehensions.hs:12:1]) - -(AK ListComprehensions.hs:12:1-27 AnnImport = [ListComprehensions.hs:12:1-6]) - -(AK ListComprehensions.hs:12:1-27 AnnSemi = [ListComprehensions.hs:13:1]) - -(AK ListComprehensions.hs:12:17-27 AnnCloseP = [ListComprehensions.hs:12:27]) - -(AK ListComprehensions.hs:12:17-27 AnnOpenP = [ListComprehensions.hs:12:17]) - -(AK ListComprehensions.hs:13:1-25 AnnImport = [ListComprehensions.hs:13:1-6]) - -(AK ListComprehensions.hs:13:1-25 AnnSemi = [ListComprehensions.hs:17:1]) - -(AK ListComprehensions.hs:13:18-25 AnnCloseP = [ListComprehensions.hs:13:25]) - -(AK ListComprehensions.hs:13:18-25 AnnOpenP = [ListComprehensions.hs:13:18]) - -(AK ListComprehensions.hs:17:1-25 AnnDcolon = [ListComprehensions.hs:17:18-19]) - -(AK ListComprehensions.hs:17:1-25 AnnSemi = [ListComprehensions.hs:18:1]) - -(AK ListComprehensions.hs:17:21-25 AnnCloseS = [ListComprehensions.hs:17:25]) - -(AK ListComprehensions.hs:17:21-25 AnnOpenS = [ListComprehensions.hs:17:21]) - -(AK ListComprehensions.hs:(18,1)-(22,20) AnnEqual = [ListComprehensions.hs:18:18]) - -(AK ListComprehensions.hs:(18,1)-(22,20) AnnFunId = [ListComprehensions.hs:18:1-16]) - -(AK ListComprehensions.hs:(18,1)-(22,20) AnnSemi = [ListComprehensions.hs:24:1]) - -(AK ListComprehensions.hs:(18,20)-(22,20) AnnCloseS = [ListComprehensions.hs:22:20]) - -(AK ListComprehensions.hs:(18,20)-(22,20) AnnOpenS = [ListComprehensions.hs:18:20]) - -(AK ListComprehensions.hs:(18,20)-(22,20) AnnVbar = [ListComprehensions.hs:19:20]) - -(AK ListComprehensions.hs:18:22-26 AnnVal = [ListComprehensions.hs:18:24]) - -(AK ListComprehensions.hs:18:22-30 AnnVal = [ListComprehensions.hs:18:28]) - -(AK ListComprehensions.hs:19:22-33 AnnLarrow = [ListComprehensions.hs:19:24-25]) - -(AK ListComprehensions.hs:19:22-33 AnnVbar = [ListComprehensions.hs:20:20]) - -(AK ListComprehensions.hs:19:27-33 AnnCloseS = [ListComprehensions.hs:19:33]) - -(AK ListComprehensions.hs:19:27-33 AnnDotdot = [ListComprehensions.hs:19:29-30]) - -(AK ListComprehensions.hs:19:27-33 AnnOpenS = [ListComprehensions.hs:19:27]) - -(AK ListComprehensions.hs:20:22-34 AnnLarrow = [ListComprehensions.hs:20:24-25]) - -(AK ListComprehensions.hs:20:22-34 AnnVbar = [ListComprehensions.hs:21:20]) - -(AK ListComprehensions.hs:20:27-34 AnnCloseS = [ListComprehensions.hs:20:34]) - -(AK ListComprehensions.hs:20:27-34 AnnDotdot = [ListComprehensions.hs:20:30-31]) - -(AK ListComprehensions.hs:20:27-34 AnnOpenS = [ListComprehensions.hs:20:27]) - -(AK ListComprehensions.hs:21:22-34 AnnLarrow = [ListComprehensions.hs:21:24-25]) - -(AK ListComprehensions.hs:21:27-34 AnnCloseS = [ListComprehensions.hs:21:34]) - -(AK ListComprehensions.hs:21:27-34 AnnDotdot = [ListComprehensions.hs:21:30-31]) - -(AK ListComprehensions.hs:21:27-34 AnnOpenS = [ListComprehensions.hs:21:27]) - -(AK ListComprehensions.hs:24:1-27 AnnDcolon = [ListComprehensions.hs:24:8-9]) - -(AK ListComprehensions.hs:24:1-27 AnnSemi = [ListComprehensions.hs:25:1]) - -(AK ListComprehensions.hs:24:11-15 AnnCloseS = [ListComprehensions.hs:24:15]) - -(AK ListComprehensions.hs:24:11-15 AnnOpenS = [ListComprehensions.hs:24:11]) - -(AK ListComprehensions.hs:24:11-15 AnnRarrow = [ListComprehensions.hs:24:17-18]) - -(AK ListComprehensions.hs:24:11-27 AnnRarrow = [ListComprehensions.hs:24:17-18]) - -(AK ListComprehensions.hs:24:20-27 AnnCloseS = [ListComprehensions.hs:24:27]) - -(AK ListComprehensions.hs:24:20-27 AnnOpenS = [ListComprehensions.hs:24:20]) - -(AK ListComprehensions.hs:(25,1)-(28,14) AnnEqual = [ListComprehensions.hs:25:12]) - -(AK ListComprehensions.hs:(25,1)-(28,14) AnnFunId = [ListComprehensions.hs:25:1-6]) - -(AK ListComprehensions.hs:(25,1)-(28,14) AnnSemi = [ListComprehensions.hs:29:1]) - -(AK ListComprehensions.hs:(25,14)-(28,14) AnnCloseS = [ListComprehensions.hs:28:14]) - -(AK ListComprehensions.hs:(25,14)-(28,14) AnnOpenS = [ListComprehensions.hs:25:14]) - -(AK ListComprehensions.hs:(25,14)-(28,14) AnnVbar = [ListComprehensions.hs:26:14]) - -(AK ListComprehensions.hs:26:16-23 AnnComma = [ListComprehensions.hs:27:14]) - -(AK ListComprehensions.hs:26:16-23 AnnLarrow = [ListComprehensions.hs:26:18-19]) - -(AK ListComprehensions.hs:(26,16)-(27,22) AnnThen = [ListComprehensions.hs:27:16-19]) -] - -EOF: Just SrcSpanPoint "./ListComprehensions.hs" 29 1 diff --git a/testsuite/tests/ghc-api/annotations/listcomps.stdout-mingw32 b/testsuite/tests/ghc-api/annotations/listcomps.stdout-mingw32 deleted file mode 100644 index 3bb7f6ce2d..0000000000 --- a/testsuite/tests/ghc-api/annotations/listcomps.stdout-mingw32 +++ /dev/null @@ -1,160 +0,0 @@ -{ListComprehensions.hs:1:1, ListComprehensions.hs:6:8-25, - ListComprehensions.hs:10:1-15, ListComprehensions.hs:10:8-15, - ListComprehensions.hs:11:1-30, ListComprehensions.hs:11:18-25, - ListComprehensions.hs:11:30, ListComprehensions.hs:12:1-27, - ListComprehensions.hs:12:8-15, ListComprehensions.hs:12:17-27, - ListComprehensions.hs:12:18-26, ListComprehensions.hs:13:1-25, - ListComprehensions.hs:13:8-16, ListComprehensions.hs:13:18-25, - ListComprehensions.hs:13:19-24, ListComprehensions.hs:17:1-16, - ListComprehensions.hs:17:1-25, ListComprehensions.hs:17:21-25, - ListComprehensions.hs:17:22-24, ListComprehensions.hs:18:1-16, - ListComprehensions.hs:(18,1)-(22,20), - ListComprehensions.hs:(18,18)-(22,20), - ListComprehensions.hs:(18,20)-(22,20), ListComprehensions.hs:18:22, - ListComprehensions.hs:18:22-26, ListComprehensions.hs:18:22-30, - ListComprehensions.hs:(18,22)-(21,34), ListComprehensions.hs:18:24, - ListComprehensions.hs:18:26, ListComprehensions.hs:18:28, - ListComprehensions.hs:18:30, ListComprehensions.hs:19:22, - ListComprehensions.hs:19:22-33, - ListComprehensions.hs:(19,22)-(21,34), - ListComprehensions.hs:19:27-33, ListComprehensions.hs:19:28, - ListComprehensions.hs:19:31-32, ListComprehensions.hs:20:22, - ListComprehensions.hs:20:22-34, ListComprehensions.hs:20:27-34, - ListComprehensions.hs:20:28-29, ListComprehensions.hs:20:32-33, - ListComprehensions.hs:21:22, ListComprehensions.hs:21:22-34, - ListComprehensions.hs:21:27-34, ListComprehensions.hs:21:28-29, - ListComprehensions.hs:21:32-33, ListComprehensions.hs:24:1-6, - ListComprehensions.hs:24:1-27, ListComprehensions.hs:24:11-15, - ListComprehensions.hs:24:11-27, ListComprehensions.hs:24:12-14, - ListComprehensions.hs:24:20-27, ListComprehensions.hs:24:21-26, - ListComprehensions.hs:25:1-6, ListComprehensions.hs:(25,1)-(28,14), - ListComprehensions.hs:25:8-10, - ListComprehensions.hs:(25,12)-(28,14), - ListComprehensions.hs:(25,14)-(28,14), - ListComprehensions.hs:25:16-20, - ListComprehensions.hs:(25,16)-(27,22), ListComprehensions.hs:26:16, - ListComprehensions.hs:26:16-23, - ListComprehensions.hs:(26,16)-(27,22), - ListComprehensions.hs:26:21-23, ListComprehensions.hs:27:21-22} --------------------------------- -[ -(AK ListComprehensions.hs:1:1 AnnModule = [ListComprehensions.hs:6:1-6]) - -(AK ListComprehensions.hs:1:1 AnnWhere = [ListComprehensions.hs:6:27-31]) - -(AK ListComprehensions.hs:10:1-15 AnnImport = [ListComprehensions.hs:10:1-6]) - -(AK ListComprehensions.hs:10:1-15 AnnSemi = [ListComprehensions.hs:11:1]) - -(AK ListComprehensions.hs:11:1-30 AnnAs = [ListComprehensions.hs:11:27-28]) - -(AK ListComprehensions.hs:11:1-30 AnnImport = [ListComprehensions.hs:11:1-6]) - -(AK ListComprehensions.hs:11:1-30 AnnQualified = [ListComprehensions.hs:11:8-16]) - -(AK ListComprehensions.hs:11:1-30 AnnSemi = [ListComprehensions.hs:12:1]) - -(AK ListComprehensions.hs:12:1-27 AnnImport = [ListComprehensions.hs:12:1-6]) - -(AK ListComprehensions.hs:12:1-27 AnnSemi = [ListComprehensions.hs:13:1]) - -(AK ListComprehensions.hs:12:17-27 AnnCloseP = [ListComprehensions.hs:12:27]) - -(AK ListComprehensions.hs:12:17-27 AnnOpenP = [ListComprehensions.hs:12:17]) - -(AK ListComprehensions.hs:13:1-25 AnnImport = [ListComprehensions.hs:13:1-6]) - -(AK ListComprehensions.hs:13:1-25 AnnSemi = [ListComprehensions.hs:17:1]) - -(AK ListComprehensions.hs:13:18-25 AnnCloseP = [ListComprehensions.hs:13:25]) - -(AK ListComprehensions.hs:13:18-25 AnnOpenP = [ListComprehensions.hs:13:18]) - -(AK ListComprehensions.hs:17:1-25 AnnDcolon = [ListComprehensions.hs:17:18-19]) - -(AK ListComprehensions.hs:17:1-25 AnnSemi = [ListComprehensions.hs:18:1]) - -(AK ListComprehensions.hs:17:21-25 AnnCloseS = [ListComprehensions.hs:17:25]) - -(AK ListComprehensions.hs:17:21-25 AnnOpenS = [ListComprehensions.hs:17:21]) - -(AK ListComprehensions.hs:(18,1)-(22,20) AnnEqual = [ListComprehensions.hs:18:18]) - -(AK ListComprehensions.hs:(18,1)-(22,20) AnnFunId = [ListComprehensions.hs:18:1-16]) - -(AK ListComprehensions.hs:(18,1)-(22,20) AnnSemi = [ListComprehensions.hs:24:1]) - -(AK ListComprehensions.hs:(18,20)-(22,20) AnnCloseS = [ListComprehensions.hs:22:20]) - -(AK ListComprehensions.hs:(18,20)-(22,20) AnnOpenS = [ListComprehensions.hs:18:20]) - -(AK ListComprehensions.hs:(18,20)-(22,20) AnnVbar = [ListComprehensions.hs:19:20]) - -(AK ListComprehensions.hs:18:22-26 AnnVal = [ListComprehensions.hs:18:24]) - -(AK ListComprehensions.hs:18:22-30 AnnVal = [ListComprehensions.hs:18:28]) - -(AK ListComprehensions.hs:19:22-33 AnnLarrow = [ListComprehensions.hs:19:24-25]) - -(AK ListComprehensions.hs:19:22-33 AnnVbar = [ListComprehensions.hs:20:20]) - -(AK ListComprehensions.hs:19:27-33 AnnCloseS = [ListComprehensions.hs:19:33]) - -(AK ListComprehensions.hs:19:27-33 AnnDotdot = [ListComprehensions.hs:19:29-30]) - -(AK ListComprehensions.hs:19:27-33 AnnOpenS = [ListComprehensions.hs:19:27]) - -(AK ListComprehensions.hs:20:22-34 AnnLarrow = [ListComprehensions.hs:20:24-25]) - -(AK ListComprehensions.hs:20:22-34 AnnVbar = [ListComprehensions.hs:21:20]) - -(AK ListComprehensions.hs:20:27-34 AnnCloseS = [ListComprehensions.hs:20:34]) - -(AK ListComprehensions.hs:20:27-34 AnnDotdot = [ListComprehensions.hs:20:30-31]) - -(AK ListComprehensions.hs:20:27-34 AnnOpenS = [ListComprehensions.hs:20:27]) - -(AK ListComprehensions.hs:21:22-34 AnnLarrow = [ListComprehensions.hs:21:24-25]) - -(AK ListComprehensions.hs:21:27-34 AnnCloseS = [ListComprehensions.hs:21:34]) - -(AK ListComprehensions.hs:21:27-34 AnnDotdot = [ListComprehensions.hs:21:30-31]) - -(AK ListComprehensions.hs:21:27-34 AnnOpenS = [ListComprehensions.hs:21:27]) - -(AK ListComprehensions.hs:24:1-27 AnnDcolon = [ListComprehensions.hs:24:8-9]) - -(AK ListComprehensions.hs:24:1-27 AnnSemi = [ListComprehensions.hs:25:1]) - -(AK ListComprehensions.hs:24:11-15 AnnCloseS = [ListComprehensions.hs:24:15]) - -(AK ListComprehensions.hs:24:11-15 AnnOpenS = [ListComprehensions.hs:24:11]) - -(AK ListComprehensions.hs:24:11-15 AnnRarrow = [ListComprehensions.hs:24:17-18]) - -(AK ListComprehensions.hs:24:11-27 AnnRarrow = [ListComprehensions.hs:24:17-18]) - -(AK ListComprehensions.hs:24:20-27 AnnCloseS = [ListComprehensions.hs:24:27]) - -(AK ListComprehensions.hs:24:20-27 AnnOpenS = [ListComprehensions.hs:24:20]) - -(AK ListComprehensions.hs:(25,1)-(28,14) AnnEqual = [ListComprehensions.hs:25:12]) - -(AK ListComprehensions.hs:(25,1)-(28,14) AnnFunId = [ListComprehensions.hs:25:1-6]) - -(AK ListComprehensions.hs:(25,1)-(28,14) AnnSemi = [ListComprehensions.hs:29:1]) - -(AK ListComprehensions.hs:(25,14)-(28,14) AnnCloseS = [ListComprehensions.hs:28:14]) - -(AK ListComprehensions.hs:(25,14)-(28,14) AnnOpenS = [ListComprehensions.hs:25:14]) - -(AK ListComprehensions.hs:(25,14)-(28,14) AnnVbar = [ListComprehensions.hs:26:14]) - -(AK ListComprehensions.hs:26:16-23 AnnComma = [ListComprehensions.hs:27:14]) - -(AK ListComprehensions.hs:26:16-23 AnnLarrow = [ListComprehensions.hs:26:18-19]) - -(AK ListComprehensions.hs:(26,16)-(27,22) AnnThen = [ListComprehensions.hs:27:16-19]) -] - -EOF: Just SrcSpanPoint ".\\ListComprehensions.hs" 29 1 diff --git a/testsuite/tests/ghc-api/annotations/load-main.stdout b/testsuite/tests/ghc-api/annotations/load-main.stdout deleted file mode 100644 index 4ba092296b..0000000000 --- a/testsuite/tests/ghc-api/annotations/load-main.stdout +++ /dev/null @@ -1,20 +0,0 @@ ----Unattached Annotation Problems (should be empty list)--- -[] ----Ann before enclosing span problem (should be empty list)--- -[ - -] - ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((load-main.hs:1:1,AnnModule), [load-main.hs:1:1-6]), -((load-main.hs:1:1,AnnWhere), [load-main.hs:1:13-17]), -((load-main.hs:4:1-23,AnnEqual), [load-main.hs:4:6]), -((load-main.hs:4:1-23,AnnFunId), [load-main.hs:4:1-4]), -((load-main.hs:4:1-23,AnnSemi), [load-main.hs:5:1]) -] - ----Eof Position (should be Just)----- -Just SrcSpanPoint "load-main.hs" 5 1 diff --git a/testsuite/tests/ghc-api/annotations/parseTree.hs b/testsuite/tests/ghc-api/annotations/parseTree.hs deleted file mode 100644 index f566c51d6f..0000000000 --- a/testsuite/tests/ghc-api/annotations/parseTree.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List (intercalate) -import System.IO -import GHC -import GHC.Types.Basic -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Data.Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir] <- getArgs - testOneFile libdir "AnnotationTuple" - -testOneFile libdir fileName = do - p <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - t <- typecheckModule p - d <- desugarModule t - l <- loadModule d - return p - - let anns = pm_annotations p - ann_items = apiAnnItems anns - ann_eof = apiAnnEofPos anns - let tupArgs = gq (pm_parsed_source p) - - putStrLn (pp tupArgs) - putStrLn (intercalate "\n" [showAnns ann_items, "EOF: " ++ show ann_eof]) - - where - gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast - - doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)] - doLHsTupArg (L l arg@(Present {})) - = [(l,"p",ExplicitTuple noExtField [L l arg] Boxed)] - doLHsTupArg (L l arg@(Missing {})) - = [(l,"m",ExplicitTuple noExtField [L l arg] Boxed)] - - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPprUnsafe a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/testsuite/tests/ghc-api/annotations/parseTree.stdout b/testsuite/tests/ghc-api/annotations/parseTree.stdout deleted file mode 100644 index 8d629fb90a..0000000000 --- a/testsuite/tests/ghc-api/annotations/parseTree.stdout +++ /dev/null @@ -1,160 +0,0 @@ -[(AnnotationTuple.hs:14:20, [p], Solo 1), - (AnnotationTuple.hs:14:23-29, [p], Solo "hello"), - (AnnotationTuple.hs:14:35-37, [p], Solo 6.5), - (AnnotationTuple.hs:14:39, [m], ()), - (AnnotationTuple.hs:14:41-52, [p], Solo [5, 5, 6, 7]), - (AnnotationTuple.hs:16:8, [p], Solo 1), - (AnnotationTuple.hs:16:11-17, [p], Solo "hello"), - (AnnotationTuple.hs:16:20-22, [p], Solo 6.5), - (AnnotationTuple.hs:16:24, [m], ()), - (AnnotationTuple.hs:16:25, [m], ()), - (AnnotationTuple.hs:16:26, [m], ()), (<no location info>, [m], ())] -[ -(AK AnnotationTuple.hs:1:1 AnnCloseC = [AnnotationTuple.hs:27:1]) - -(AK AnnotationTuple.hs:1:1 AnnModule = [AnnotationTuple.hs:3:1-6]) - -(AK AnnotationTuple.hs:1:1 AnnOpenC = [AnnotationTuple.hs:5:1]) - -(AK AnnotationTuple.hs:1:1 AnnWhere = [AnnotationTuple.hs:3:30-34]) - -(AK AnnotationTuple.hs:3:24-28 AnnCloseP = [AnnotationTuple.hs:3:28]) - -(AK AnnotationTuple.hs:3:24-28 AnnOpenP = [AnnotationTuple.hs:3:24]) - -(AK AnnotationTuple.hs:6:1-32 AnnAs = [AnnotationTuple.hs:6:28-29]) - -(AK AnnotationTuple.hs:6:1-32 AnnImport = [AnnotationTuple.hs:6:1-6]) - -(AK AnnotationTuple.hs:6:1-32 AnnQualified = [AnnotationTuple.hs:6:8-16]) - -(AK AnnotationTuple.hs:6:1-32 AnnSemi = [AnnotationTuple.hs:7:1]) - -(AK AnnotationTuple.hs:(8,1)-(11,14) AnnEqual = [AnnotationTuple.hs:8:5]) - -(AK AnnotationTuple.hs:(8,1)-(11,14) AnnFunId = [AnnotationTuple.hs:8:1-3]) - -(AK AnnotationTuple.hs:(8,1)-(11,14) AnnSemi = [AnnotationTuple.hs:13:1]) - -(AK AnnotationTuple.hs:(8,7)-(11,14) AnnIn = [AnnotationTuple.hs:11:7-8]) - -(AK AnnotationTuple.hs:(8,7)-(11,14) AnnLet = [AnnotationTuple.hs:8:7-9]) - -(AK AnnotationTuple.hs:9:9-13 AnnEqual = [AnnotationTuple.hs:9:11]) - -(AK AnnotationTuple.hs:9:9-13 AnnFunId = [AnnotationTuple.hs:9:9]) - -(AK AnnotationTuple.hs:9:9-13 AnnSemi = [AnnotationTuple.hs:10:9]) - -(AK AnnotationTuple.hs:10:9-13 AnnEqual = [AnnotationTuple.hs:10:11]) - -(AK AnnotationTuple.hs:10:9-13 AnnFunId = [AnnotationTuple.hs:10:9]) - -(AK AnnotationTuple.hs:11:10-14 AnnVal = [AnnotationTuple.hs:11:12]) - -(AK AnnotationTuple.hs:14:1-72 AnnEqual = [AnnotationTuple.hs:14:5]) - -(AK AnnotationTuple.hs:14:1-72 AnnFunId = [AnnotationTuple.hs:14:1-3]) - -(AK AnnotationTuple.hs:14:1-72 AnnSemi = [AnnotationTuple.hs:15:1]) - -(AK AnnotationTuple.hs:14:7-72 AnnVal = [AnnotationTuple.hs:14:13]) - -(AK AnnotationTuple.hs:14:19-53 AnnCloseP = [AnnotationTuple.hs:14:53]) - -(AK AnnotationTuple.hs:14:19-53 AnnOpenP = [AnnotationTuple.hs:14:19]) - -(AK AnnotationTuple.hs:14:20 AnnComma = [AnnotationTuple.hs:14:21]) - -(AK AnnotationTuple.hs:14:23-29 AnnComma = [AnnotationTuple.hs:14:33]) - -(AK AnnotationTuple.hs:14:35-37 AnnComma = [AnnotationTuple.hs:14:38]) - -(AK AnnotationTuple.hs:14:39 AnnComma = [AnnotationTuple.hs:14:39]) - -(AK AnnotationTuple.hs:14:41-52 AnnCloseS = [AnnotationTuple.hs:14:52]) - -(AK AnnotationTuple.hs:14:41-52 AnnOpenS = [AnnotationTuple.hs:14:41]) - -(AK AnnotationTuple.hs:14:42 AnnComma = [AnnotationTuple.hs:14:43]) - -(AK AnnotationTuple.hs:14:45 AnnComma = [AnnotationTuple.hs:14:46]) - -(AK AnnotationTuple.hs:14:48 AnnComma = [AnnotationTuple.hs:14:49]) - -(AK AnnotationTuple.hs:14:55-72 AnnCloseS = [AnnotationTuple.hs:14:72]) - -(AK AnnotationTuple.hs:14:55-72 AnnOpenS = [AnnotationTuple.hs:14:55]) - -(AK AnnotationTuple.hs:14:56-62 AnnComma = [AnnotationTuple.hs:14:63]) - -(AK AnnotationTuple.hs:14:61-62 AnnCloseP = [AnnotationTuple.hs:14:62]) - -(AK AnnotationTuple.hs:14:61-62 AnnOpenP = [AnnotationTuple.hs:14:61]) - -(AK AnnotationTuple.hs:16:1-41 AnnEqual = [AnnotationTuple.hs:16:5]) - -(AK AnnotationTuple.hs:16:1-41 AnnFunId = [AnnotationTuple.hs:16:1-3]) - -(AK AnnotationTuple.hs:16:1-41 AnnSemi = [AnnotationTuple.hs:17:1]) - -(AK AnnotationTuple.hs:16:7-27 AnnCloseP = [AnnotationTuple.hs:16:27]) - -(AK AnnotationTuple.hs:16:7-27 AnnOpenP = [AnnotationTuple.hs:16:7]) - -(AK AnnotationTuple.hs:16:8 AnnComma = [AnnotationTuple.hs:16:9]) - -(AK AnnotationTuple.hs:16:11-17 AnnComma = [AnnotationTuple.hs:16:18]) - -(AK AnnotationTuple.hs:16:20-22 AnnComma = [AnnotationTuple.hs:16:23]) - -(AK AnnotationTuple.hs:16:24 AnnComma = [AnnotationTuple.hs:16:24]) - -(AK AnnotationTuple.hs:16:25 AnnComma = [AnnotationTuple.hs:16:25]) - -(AK AnnotationTuple.hs:16:26 AnnComma = [AnnotationTuple.hs:16:26]) - -(AK AnnotationTuple.hs:16:33-41 AnnCloseP = [AnnotationTuple.hs:16:41]) - -(AK AnnotationTuple.hs:16:33-41 AnnOpenP = [AnnotationTuple.hs:16:33]) - -(AK AnnotationTuple.hs:16:39-40 AnnCloseP = [AnnotationTuple.hs:16:40]) - -(AK AnnotationTuple.hs:16:39-40 AnnOpenP = [AnnotationTuple.hs:16:39]) - -(AK AnnotationTuple.hs:18:1-28 AnnData = [AnnotationTuple.hs:18:1-4]) - -(AK AnnotationTuple.hs:18:1-28 AnnDcolon = [AnnotationTuple.hs:18:20-21]) - -(AK AnnotationTuple.hs:18:1-28 AnnFamily = [AnnotationTuple.hs:18:6-11]) - -(AK AnnotationTuple.hs:18:1-28 AnnSemi = [AnnotationTuple.hs:19:1]) - -(AK AnnotationTuple.hs:18:23 AnnRarrow = [AnnotationTuple.hs:18:25-26]) - -(AK AnnotationTuple.hs:18:23-28 AnnRarrow = [AnnotationTuple.hs:18:25-26]) - -(AK AnnotationTuple.hs:(20,1)-(24,14) AnnFunId = [AnnotationTuple.hs:20:1-5]) - -(AK AnnotationTuple.hs:(20,1)-(24,14) AnnSemi = [AnnotationTuple.hs:25:1]) - -(AK AnnotationTuple.hs:(21,7)-(24,14) AnnEqual = [AnnotationTuple.hs:24:7]) - -(AK AnnotationTuple.hs:(21,7)-(24,14) AnnVbar = [AnnotationTuple.hs:21:7]) - -(AK AnnotationTuple.hs:21:9-24 AnnComma = [AnnotationTuple.hs:22:7]) - -(AK AnnotationTuple.hs:21:9-24 AnnLarrow = [AnnotationTuple.hs:21:16-17]) - -(AK AnnotationTuple.hs:22:9-25 AnnComma = [AnnotationTuple.hs:23:7]) - -(AK AnnotationTuple.hs:22:9-25 AnnLarrow = [AnnotationTuple.hs:22:16-17]) - -(AK AnnotationTuple.hs:23:9-24 AnnLarrow = [AnnotationTuple.hs:23:16-17]) - -(AK AnnotationTuple.hs:26:1-10 AnnDcolon = [AnnotationTuple.hs:26:5-6]) - -(AK AnnotationTuple.hs:26:1-14 AnnEqual = [AnnotationTuple.hs:26:12]) -] - -EOF: Just SrcSpanPoint "./AnnotationTuple.hs" 32 1 diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index e0f5a33d69..893ffb232e 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -1,1106 +1,2162 @@ ==================== Parser AST ==================== -({ T17544.hs:1:1 } +(L + { T17544.hs:1:1 } (HsModule + (ApiAnn + (Anchor + { T17544.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddApiAnn AnnModule (AR { T17544.hs:3:1-6 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:3:15-19 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { T17544.hs:57:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { T17544.hs:57:1 }))])) (VirtualBraces (1)) (Just - ({ T17544.hs:3:8-13 } + (L + { T17544.hs:3:8-13 } {ModuleName: T17544})) (Nothing) [] - [({ T17544.hs:(5,1)-(6,16) } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(5,1)-(6,16) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(5,1)-(6,16) }) (TyClD (NoExtField) (ClassDecl - (VirtualBraces - (3)) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:(5,1)-(6,16) } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:5:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:5:12-16 }))] + (AnnComments + [])) + (NoAnnSortKey) + (VirtualBraces + (3))) (Nothing) - ({ T17544.hs:5:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:5:7-8 }) (Unqual {OccName: C1})) (HsQTvs (NoExtField) - [({ T17544.hs:5:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:5:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:5:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:5:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:5:10 }) (Unqual {OccName: a}))))]) (Prefix) [] - [({ T17544.hs:6:3-16 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:3-16 }) (ClassOpSig - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:6:3-4 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { T17544.hs:6:6-7 })) + []) + (AnnComments + [])) (False) - [({ T17544.hs:6:3-4 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:3-4 }) (Unqual {OccName: f1}))] - ({ T17544.hs:6:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:9-16 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:6:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:9-16 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:6:9 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { T17544.hs:6:11-12 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ T17544.hs:6:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:9 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:6:9 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:6:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:9 }) (Unqual {OccName: a})))) - ({ T17544.hs:6:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:14-16 }) (HsDocTy - (NoExtField) - ({ T17544.hs:6:14-16 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:6:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:6:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:6:14-16 }) (Unqual {OccName: Int})))) - ({ T17544.hs:7:5-23 } + (L + { T17544.hs:7:5-23 } (HsDocString " comment on Int"))))))))))] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] []))) - ,({ T17544.hs:(9,1)-(10,16) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(9,1)-(10,16) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(9,1)-(10,16) }) (TyClD (NoExtField) (ClassDecl - (VirtualBraces - (3)) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:(9,1)-(10,16) } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:9:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:9:12-16 }))] + (AnnComments + [])) + (NoAnnSortKey) + (VirtualBraces + (3))) (Nothing) - ({ T17544.hs:9:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:9:7-8 }) (Unqual {OccName: C2})) (HsQTvs (NoExtField) - [({ T17544.hs:9:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:9:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:9:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:9:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:9:10 }) (Unqual {OccName: a}))))]) (Prefix) [] - [({ T17544.hs:10:3-16 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:3-16 }) (ClassOpSig - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:10:3-4 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { T17544.hs:10:6-7 })) + []) + (AnnComments + [])) (False) - [({ T17544.hs:10:3-4 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:3-4 }) (Unqual {OccName: f2}))] - ({ T17544.hs:10:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:9-16 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:10:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:9-16 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:10:9 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { T17544.hs:10:11-12 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ T17544.hs:10:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:9 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:10:9 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:10:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:9 }) (Unqual {OccName: a})))) - ({ T17544.hs:10:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:10:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:10:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:10:14-16 }) (Unqual {OccName: Int}))))))))))] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544.hs:11:3-20 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:11:3-20 }) (DocCommentPrev (HsDocString " comment on f2")))]))) - ,({ T17544.hs:(13,1)-(14,16) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(13,1)-(14,16) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(13,1)-(14,16) }) (TyClD (NoExtField) (ClassDecl - (VirtualBraces - (3)) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:(13,1)-(14,16) } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:13:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:13:12-16 }))] + (AnnComments + [])) + (NoAnnSortKey) + (VirtualBraces + (3))) (Nothing) - ({ T17544.hs:13:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:13:7-8 }) (Unqual {OccName: C3})) (HsQTvs (NoExtField) - [({ T17544.hs:13:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:13:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:13:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:13:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:13:10 }) (Unqual {OccName: a}))))]) (Prefix) [] - [({ T17544.hs:14:3-16 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:3-16 }) (ClassOpSig - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:14:3-4 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { T17544.hs:14:6-7 })) + []) + (AnnComments + [])) (False) - [({ T17544.hs:14:3-4 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:3-4 }) (Unqual {OccName: f3}))] - ({ T17544.hs:14:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:9-16 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:14:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:9-16 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:14:9 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { T17544.hs:14:11-12 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ T17544.hs:14:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:9 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:14:9 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:14:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:9 }) (Unqual {OccName: a})))) - ({ T17544.hs:14:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:14:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:14:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:14:14-16 }) (Unqual {OccName: Int}))))))))))] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] []))) - ,({ T17544.hs:15:1-18 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:15:1-18 }) (DocD (NoExtField) (DocCommentPrev (HsDocString " comment on C3")))) - ,({ T17544.hs:(17,1)-(20,16) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(17,1)-(20,16) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(17,1)-(20,16) }) (TyClD (NoExtField) (ClassDecl - (VirtualBraces - (3)) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:(17,1)-(20,16) } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:17:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:17:12-16 }))] + (AnnComments + [])) + (NoAnnSortKey) + (VirtualBraces + (3))) (Nothing) - ({ T17544.hs:17:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:17:7-8 }) (Unqual {OccName: C4})) (HsQTvs (NoExtField) - [({ T17544.hs:17:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:17:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:17:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:17:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:17:10 }) (Unqual {OccName: a}))))]) (Prefix) [] - [({ T17544.hs:18:3-16 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:3-16 }) (ClassOpSig - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:18:3-4 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { T17544.hs:18:6-7 })) + []) + (AnnComments + [])) (False) - [({ T17544.hs:18:3-4 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:3-4 }) (Unqual {OccName: f4}))] - ({ T17544.hs:18:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:9-16 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:18:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:9-16 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:18:9 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { T17544.hs:18:11-12 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ T17544.hs:18:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:9 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:18:9 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:18:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:9 }) (Unqual {OccName: a})))) - ({ T17544.hs:18:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:18:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:18:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:18:14-16 }) (Unqual {OccName: Int})))))))))) - ,({ T17544.hs:20:3-16 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:3-16 }) (ClassOpSig - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:20:3-4 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { T17544.hs:20:6-7 })) + []) + (AnnComments + [])) (False) - [({ T17544.hs:20:3-4 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:3-4 }) (Unqual {OccName: g4}))] - ({ T17544.hs:20:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:9-16 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:20:9-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:9-16 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:20:9 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { T17544.hs:20:11-12 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ T17544.hs:20:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:9 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:20:9 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:20:9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:9 }) (Unqual {OccName: a})))) - ({ T17544.hs:20:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:20:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:20:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:20:14-16 }) (Unqual {OccName: Int}))))))))))] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] []))) - ,({ T17544.hs:22:1-30 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:22:1-30 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:22:1-30 }) (TyClD (NoExtField) (ClassDecl - (ExplicitBraces) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:22:1-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:22:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:22:12-16 })) + ,(AddApiAnn AnnOpenC (AR { T17544.hs:22:18 })) + ,(AddApiAnn AnnCloseC (AR { T17544.hs:22:30 }))] + (AnnComments + [])) + (NoAnnSortKey) + (ExplicitBraces)) (Nothing) - ({ T17544.hs:22:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:22:7-8 }) (Unqual {OccName: C5})) (HsQTvs (NoExtField) - [({ T17544.hs:22:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:22:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:22:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:22:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:22:10 }) (Unqual {OccName: a}))))]) (Prefix) [] [] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} - [({ T17544.hs:22:20-28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:22:20-28 }) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:22:20-28 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:22:20-23 }))] + (AnnComments + [])) (DataFamily) - ({ T17544.hs:22:25-26 } + (NotTopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:22:25-26 }) (Unqual {OccName: D5})) (HsQTvs (NoExtField) - [({ T17544.hs:22:28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:22:28 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:22:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:22:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:22:28 }) (Unqual {OccName: a}))))]) (Prefix) - ({ <no location info> } + (L + { <no location info> } (NoSig (NoExtField))) (Nothing)))] [] []))) - ,({ T17544.hs:(23,1)-(25,18) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(23,1)-(25,18) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(23,1)-(25,18) }) (InstD (NoExtField) (ClsInstD (NoExtField) (ClsInstDecl - (NoExtField) - ({ T17544.hs:23:10-15 } + ((,) + (ApiAnn + (Anchor + { T17544.hs:23:1-8 } + (UnchangedAnchor)) + [(AddApiAnn AnnInstance (AR { T17544.hs:23:1-8 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:23:17-21 }))] + (AnnComments + [])) + (NoAnnSortKey)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:23:10-15 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:23:10-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:23:10-15 }) (HsAppTy (NoExtField) - ({ T17544.hs:23:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:23:10-11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:23:10-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:23:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:23:10-11 }) (Unqual {OccName: C5})))) - ({ T17544.hs:23:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:23:13-15 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:23:13-15 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:23:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:23:13-15 }) (Unqual {OccName: Int})))))))) - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544.hs:(24,3)-(25,18) } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:(24,3)-(25,18) }) (DataFamInstDecl (FamEqn - (NoExtField) - ({ T17544.hs:24:8-9 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:24:8-9 }) (Unqual {OccName: D5})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ T17544.hs:24:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:24:11-13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:24:11-13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:24:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:24:11-13 }) (Unqual {OccName: Int})))))] (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:(24,3)-(25,18) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:24:3-6 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:24:15-19 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T17544.hs:25:5-18 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:5-18 }) (ConDeclGADT - (NoExtField) - [({ T17544.hs:25:5-8 } + (ApiAnn + (Anchor + { T17544.hs:25:5-18 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544.hs:25:10-11 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:5-8 }) (Unqual {OccName: MkD5}))] - ({ T17544.hs:25:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:13-18 }) (HsOuterImplicit (NoExtField))) (Nothing) (PrefixConGADT []) - ({ T17544.hs:25:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:13-18 }) (HsAppTy (NoExtField) - ({ T17544.hs:25:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:13-14 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:25:13-14 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:25:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:13-14 }) (Unqual {OccName: D5})))) - ({ T17544.hs:25:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:16-18 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:25:16-18 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:25:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:25:16-18 }) (Unqual {OccName: Int})))))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing))))) - ,({ T17544.hs:28:1-30 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:28:1-30 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:28:1-30 }) (TyClD (NoExtField) (ClassDecl - (ExplicitBraces) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:28:1-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:28:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:28:12-16 })) + ,(AddApiAnn AnnOpenC (AR { T17544.hs:28:18 })) + ,(AddApiAnn AnnCloseC (AR { T17544.hs:28:30 }))] + (AnnComments + [])) + (NoAnnSortKey) + (ExplicitBraces)) (Nothing) - ({ T17544.hs:28:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:28:7-8 }) (Unqual {OccName: C6})) (HsQTvs (NoExtField) - [({ T17544.hs:28:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:28:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:28:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:28:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:28:10 }) (Unqual {OccName: a}))))]) (Prefix) [] [] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} - [({ T17544.hs:28:20-28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:28:20-28 }) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:28:20-28 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:28:20-23 }))] + (AnnComments + [])) (DataFamily) - ({ T17544.hs:28:25-26 } + (NotTopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:28:25-26 }) (Unqual {OccName: D6})) (HsQTvs (NoExtField) - [({ T17544.hs:28:28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:28:28 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:28:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:28:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:28:28 }) (Unqual {OccName: a}))))]) (Prefix) - ({ <no location info> } + (L + { <no location info> } (NoSig (NoExtField))) (Nothing)))] [] []))) - ,({ T17544.hs:(29,1)-(31,18) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(29,1)-(31,18) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(29,1)-(31,18) }) (InstD (NoExtField) (ClsInstD (NoExtField) (ClsInstDecl - (NoExtField) - ({ T17544.hs:29:10-15 } + ((,) + (ApiAnn + (Anchor + { T17544.hs:29:1-8 } + (UnchangedAnchor)) + [(AddApiAnn AnnInstance (AR { T17544.hs:29:1-8 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:29:17-21 }))] + (AnnComments + [])) + (NoAnnSortKey)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:29:10-15 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:29:10-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:29:10-15 }) (HsAppTy (NoExtField) - ({ T17544.hs:29:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:29:10-11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:29:10-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:29:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:29:10-11 }) (Unqual {OccName: C6})))) - ({ T17544.hs:29:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:29:13-15 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:29:13-15 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:29:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:29:13-15 }) (Unqual {OccName: Int})))))))) - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544.hs:(30,3)-(31,18) } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:(30,3)-(31,18) }) (DataFamInstDecl (FamEqn - (NoExtField) - ({ T17544.hs:30:8-9 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:30:8-9 }) (Unqual {OccName: D6})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ T17544.hs:30:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:30:11-13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:30:11-13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:30:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:30:11-13 }) (Unqual {OccName: Int})))))] (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:(30,3)-(31,18) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:30:3-6 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:30:15-19 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T17544.hs:31:5-18 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:5-18 }) (ConDeclGADT - (NoExtField) - [({ T17544.hs:31:5-8 } + (ApiAnn + (Anchor + { T17544.hs:31:5-18 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544.hs:31:10-11 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:5-8 }) (Unqual {OccName: MkD6}))] - ({ T17544.hs:31:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:13-18 }) (HsOuterImplicit (NoExtField))) (Nothing) (PrefixConGADT []) - ({ T17544.hs:31:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:13-18 }) (HsAppTy (NoExtField) - ({ T17544.hs:31:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:13-14 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:31:13-14 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:31:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:13-14 }) (Unqual {OccName: D6})))) - ({ T17544.hs:31:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:16-18 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:31:16-18 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:31:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:31:16-18 }) (Unqual {OccName: Int})))))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing))))) - ,({ T17544.hs:34:1-30 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:34:1-30 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:34:1-30 }) (TyClD (NoExtField) (ClassDecl - (ExplicitBraces) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:34:1-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:34:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:34:12-16 })) + ,(AddApiAnn AnnOpenC (AR { T17544.hs:34:18 })) + ,(AddApiAnn AnnCloseC (AR { T17544.hs:34:30 }))] + (AnnComments + [])) + (NoAnnSortKey) + (ExplicitBraces)) (Nothing) - ({ T17544.hs:34:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:34:7-8 }) (Unqual {OccName: C7})) (HsQTvs (NoExtField) - [({ T17544.hs:34:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:34:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:34:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:34:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:34:10 }) (Unqual {OccName: a}))))]) (Prefix) [] [] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} - [({ T17544.hs:34:20-28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:34:20-28 }) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:34:20-28 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:34:20-23 }))] + (AnnComments + [])) (DataFamily) - ({ T17544.hs:34:25-26 } + (NotTopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:34:25-26 }) (Unqual {OccName: D7})) (HsQTvs (NoExtField) - [({ T17544.hs:34:28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:34:28 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:34:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:34:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:34:28 }) (Unqual {OccName: a}))))]) (Prefix) - ({ <no location info> } + (L + { <no location info> } (NoSig (NoExtField))) (Nothing)))] [] []))) - ,({ T17544.hs:(35,1)-(37,18) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(35,1)-(37,18) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(35,1)-(37,18) }) (InstD (NoExtField) (ClsInstD (NoExtField) (ClsInstDecl - (NoExtField) - ({ T17544.hs:35:10-15 } + ((,) + (ApiAnn + (Anchor + { T17544.hs:35:1-8 } + (UnchangedAnchor)) + [(AddApiAnn AnnInstance (AR { T17544.hs:35:1-8 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:35:17-21 }))] + (AnnComments + [])) + (NoAnnSortKey)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:35:10-15 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:35:10-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:35:10-15 }) (HsAppTy (NoExtField) - ({ T17544.hs:35:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:35:10-11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:35:10-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:35:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:35:10-11 }) (Unqual {OccName: C7})))) - ({ T17544.hs:35:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:35:13-15 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:35:13-15 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:35:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:35:13-15 }) (Unqual {OccName: Int})))))))) - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544.hs:(36,3)-(37,18) } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:(36,3)-(37,18) }) (DataFamInstDecl (FamEqn - (NoExtField) - ({ T17544.hs:36:8-9 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:36:8-9 }) (Unqual {OccName: D7})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ T17544.hs:36:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:36:11-13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:36:11-13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:36:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:36:11-13 }) (Unqual {OccName: Int})))))] (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:(36,3)-(37,18) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:36:3-6 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:36:15-19 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T17544.hs:37:5-18 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:5-18 }) (ConDeclGADT - (NoExtField) - [({ T17544.hs:37:5-8 } + (ApiAnn + (Anchor + { T17544.hs:37:5-18 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544.hs:37:10-11 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:5-8 }) (Unqual {OccName: MkD7}))] - ({ T17544.hs:37:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:13-18 }) (HsOuterImplicit (NoExtField))) (Nothing) (PrefixConGADT []) - ({ T17544.hs:37:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:13-18 }) (HsAppTy (NoExtField) - ({ T17544.hs:37:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:13-14 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:37:13-14 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:37:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:13-14 }) (Unqual {OccName: D7})))) - ({ T17544.hs:37:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:16-18 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:37:16-18 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:37:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:37:16-18 }) (Unqual {OccName: Int})))))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing))))) - ,({ T17544.hs:40:1-30 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:40:1-30 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:40:1-30 }) (TyClD (NoExtField) (ClassDecl - (ExplicitBraces) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:40:1-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:40:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:40:12-16 })) + ,(AddApiAnn AnnOpenC (AR { T17544.hs:40:18 })) + ,(AddApiAnn AnnCloseC (AR { T17544.hs:40:30 }))] + (AnnComments + [])) + (NoAnnSortKey) + (ExplicitBraces)) (Nothing) - ({ T17544.hs:40:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:40:7-8 }) (Unqual {OccName: C8})) (HsQTvs (NoExtField) - [({ T17544.hs:40:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:40:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:40:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:40:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:40:10 }) (Unqual {OccName: a}))))]) (Prefix) [] [] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} - [({ T17544.hs:40:20-28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:40:20-28 }) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:40:20-28 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:40:20-23 }))] + (AnnComments + [])) (DataFamily) - ({ T17544.hs:40:25-26 } + (NotTopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:40:25-26 }) (Unqual {OccName: D8})) (HsQTvs (NoExtField) - [({ T17544.hs:40:28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:40:28 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:40:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:40:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:40:28 }) (Unqual {OccName: a}))))]) (Prefix) - ({ <no location info> } + (L + { <no location info> } (NoSig (NoExtField))) (Nothing)))] [] []))) - ,({ T17544.hs:(41,1)-(43,18) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(41,1)-(43,18) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(41,1)-(43,18) }) (InstD (NoExtField) (ClsInstD (NoExtField) (ClsInstDecl - (NoExtField) - ({ T17544.hs:41:10-15 } + ((,) + (ApiAnn + (Anchor + { T17544.hs:41:1-8 } + (UnchangedAnchor)) + [(AddApiAnn AnnInstance (AR { T17544.hs:41:1-8 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:41:17-21 }))] + (AnnComments + [])) + (NoAnnSortKey)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:41:10-15 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:41:10-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:41:10-15 }) (HsAppTy (NoExtField) - ({ T17544.hs:41:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:41:10-11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:41:10-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:41:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:41:10-11 }) (Unqual {OccName: C8})))) - ({ T17544.hs:41:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:41:13-15 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:41:13-15 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:41:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:41:13-15 }) (Unqual {OccName: Int})))))))) - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544.hs:(42,3)-(43,18) } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:(42,3)-(43,18) }) (DataFamInstDecl (FamEqn - (NoExtField) - ({ T17544.hs:42:8-9 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:42:8-9 }) (Unqual {OccName: D8})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ T17544.hs:42:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:42:11-13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:42:11-13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:42:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:42:11-13 }) (Unqual {OccName: Int})))))] (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:(42,3)-(43,18) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:42:3-6 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:42:15-19 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T17544.hs:43:5-18 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:5-18 }) (ConDeclGADT - (NoExtField) - [({ T17544.hs:43:5-8 } + (ApiAnn + (Anchor + { T17544.hs:43:5-18 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544.hs:43:10-11 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:5-8 }) (Unqual {OccName: MkD8}))] - ({ T17544.hs:43:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:13-18 }) (HsOuterImplicit (NoExtField))) (Nothing) (PrefixConGADT []) - ({ T17544.hs:43:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:13-18 }) (HsAppTy (NoExtField) - ({ T17544.hs:43:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:13-14 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:43:13-14 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:43:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:13-14 }) (Unqual {OccName: D8})))) - ({ T17544.hs:43:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:16-18 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:43:16-18 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:43:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:43:16-18 }) (Unqual {OccName: Int})))))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing))))) - ,({ T17544.hs:46:1-30 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:46:1-30 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:46:1-30 }) (TyClD (NoExtField) (ClassDecl - (ExplicitBraces) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:46:1-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:46:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:46:12-16 })) + ,(AddApiAnn AnnOpenC (AR { T17544.hs:46:18 })) + ,(AddApiAnn AnnCloseC (AR { T17544.hs:46:30 }))] + (AnnComments + [])) + (NoAnnSortKey) + (ExplicitBraces)) (Nothing) - ({ T17544.hs:46:7-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:46:7-8 }) (Unqual {OccName: C9})) (HsQTvs (NoExtField) - [({ T17544.hs:46:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:46:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:46:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:46:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:46:10 }) (Unqual {OccName: a}))))]) (Prefix) [] [] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} - [({ T17544.hs:46:20-28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:46:20-28 }) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:46:20-28 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:46:20-23 }))] + (AnnComments + [])) (DataFamily) - ({ T17544.hs:46:25-26 } + (NotTopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:46:25-26 }) (Unqual {OccName: D9})) (HsQTvs (NoExtField) - [({ T17544.hs:46:28 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:46:28 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:46:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:46:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:46:28 }) (Unqual {OccName: a}))))]) (Prefix) - ({ <no location info> } + (L + { <no location info> } (NoSig (NoExtField))) (Nothing)))] [] []))) - ,({ T17544.hs:(47,1)-(49,18) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(47,1)-(49,18) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(47,1)-(49,18) }) (InstD (NoExtField) (ClsInstD (NoExtField) (ClsInstDecl - (NoExtField) - ({ T17544.hs:47:10-15 } + ((,) + (ApiAnn + (Anchor + { T17544.hs:47:1-8 } + (UnchangedAnchor)) + [(AddApiAnn AnnInstance (AR { T17544.hs:47:1-8 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:47:17-21 }))] + (AnnComments + [])) + (NoAnnSortKey)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:47:10-15 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:47:10-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:47:10-15 }) (HsAppTy (NoExtField) - ({ T17544.hs:47:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:47:10-11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:47:10-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:47:10-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:47:10-11 }) (Unqual {OccName: C9})))) - ({ T17544.hs:47:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:47:13-15 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:47:13-15 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:47:13-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:47:13-15 }) (Unqual {OccName: Int})))))))) - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544.hs:(48,3)-(49,18) } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:(48,3)-(49,18) }) (DataFamInstDecl (FamEqn - (NoExtField) - ({ T17544.hs:48:8-9 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:48:8-9 }) (Unqual {OccName: D9})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ T17544.hs:48:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:48:11-13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:48:11-13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:48:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:48:11-13 }) (Unqual {OccName: Int})))))] (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:(48,3)-(49,18) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:48:3-6 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:48:15-19 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T17544.hs:49:5-18 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:5-18 }) (ConDeclGADT - (NoExtField) - [({ T17544.hs:49:5-8 } + (ApiAnn + (Anchor + { T17544.hs:49:5-18 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544.hs:49:10-11 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:5-8 }) (Unqual {OccName: MkD9}))] - ({ T17544.hs:49:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:13-18 }) (HsOuterImplicit (NoExtField))) (Nothing) (PrefixConGADT []) - ({ T17544.hs:49:13-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:13-18 }) (HsAppTy (NoExtField) - ({ T17544.hs:49:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:13-14 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:49:13-14 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:49:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:13-14 }) (Unqual {OccName: D9})))) - ({ T17544.hs:49:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:16-18 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:49:16-18 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:49:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:49:16-18 }) (Unqual {OccName: Int})))))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing))))) - ,({ T17544.hs:52:1-32 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:52:1-32 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:52:1-32 }) (TyClD (NoExtField) (ClassDecl - (ExplicitBraces) + ((,,) + (ApiAnn + (Anchor + { T17544.hs:52:1-32 } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544.hs:52:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:52:13-17 })) + ,(AddApiAnn AnnOpenC (AR { T17544.hs:52:19 })) + ,(AddApiAnn AnnCloseC (AR { T17544.hs:52:32 }))] + (AnnComments + [])) + (NoAnnSortKey) + (ExplicitBraces)) (Nothing) - ({ T17544.hs:52:7-9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:52:7-9 }) (Unqual {OccName: C10})) (HsQTvs (NoExtField) - [({ T17544.hs:52:11 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:52:11 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:52:11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:52:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:52:11 }) (Unqual {OccName: a}))))]) (Prefix) [] [] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} - [({ T17544.hs:52:21-30 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:52:21-30 }) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:52:21-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:52:21-24 }))] + (AnnComments + [])) (DataFamily) - ({ T17544.hs:52:26-28 } + (NotTopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:52:26-28 }) (Unqual {OccName: D10})) (HsQTvs (NoExtField) - [({ T17544.hs:52:30 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:52:30 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:52:30 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544.hs:52:30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:52:30 }) (Unqual {OccName: a}))))]) (Prefix) - ({ <no location info> } + (L + { <no location info> } (NoSig (NoExtField))) (Nothing)))] [] []))) - ,({ T17544.hs:(53,1)-(55,20) } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544.hs:(53,1)-(55,20) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544.hs:(53,1)-(55,20) }) (InstD (NoExtField) (ClsInstD (NoExtField) (ClsInstDecl - (NoExtField) - ({ T17544.hs:53:10-16 } + ((,) + (ApiAnn + (Anchor + { T17544.hs:53:1-8 } + (UnchangedAnchor)) + [(AddApiAnn AnnInstance (AR { T17544.hs:53:1-8 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:53:18-22 }))] + (AnnComments + [])) + (NoAnnSortKey)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:53:10-16 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544.hs:53:10-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:53:10-16 }) (HsAppTy (NoExtField) - ({ T17544.hs:53:10-12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:53:10-12 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:53:10-12 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:53:10-12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:53:10-12 }) (Unqual {OccName: C10})))) - ({ T17544.hs:53:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:53:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:53:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:53:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:53:14-16 }) (Unqual {OccName: Int})))))))) - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544.hs:(54,3)-(55,20) } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:(54,3)-(55,20) }) (DataFamInstDecl (FamEqn - (NoExtField) - ({ T17544.hs:54:8-10 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:54:8-10 }) (Unqual {OccName: D10})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ T17544.hs:54:12-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:54:12-14 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:54:12-14 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:54:12-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:54:12-14 }) (Unqual {OccName: Int})))))] (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:(54,3)-(55,20) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544.hs:54:3-6 })) + ,(AddApiAnn AnnWhere (AR { T17544.hs:54:16-20 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T17544.hs:55:5-20 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:5-20 }) (ConDeclGADT - (NoExtField) - [({ T17544.hs:55:5-9 } + (ApiAnn + (Anchor + { T17544.hs:55:5-20 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544.hs:55:11-12 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:5-9 }) (Unqual {OccName: MkD10}))] - ({ T17544.hs:55:14-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:14-20 }) (HsOuterImplicit (NoExtField))) (Nothing) (PrefixConGADT []) - ({ T17544.hs:55:14-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:14-20 }) (HsAppTy (NoExtField) - ({ T17544.hs:55:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:55:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:55:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:14-16 }) (Unqual {OccName: D10})))) - ({ T17544.hs:55:18-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:18-20 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544.hs:55:18-20 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544.hs:55:18-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:55:18-20 }) (Unqual {OccName: Int})))))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing))))) - ,({ T17544.hs:56:1-38 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544.hs:56:1-38 }) (DocD (NoExtField) (DocCommentPrev diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index 2ebdf9dec9..c53e76def5 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -1,21 +1,61 @@ ==================== Parser AST ==================== -({ T17544_kw.hs:1:1 } +(L + { T17544_kw.hs:1:1 } (HsModule + (ApiAnn + (Anchor + { T17544_kw.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddApiAnn AnnModule (AR { T17544_kw.hs:11:1-6 })) + ,(AddApiAnn AnnWhere (AR { T17544_kw.hs:13:13-17 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { T17544_kw.hs:25:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { T17544_kw.hs:25:1 }))])) (VirtualBraces (1)) (Just - ({ T17544_kw.hs:13:3-11 } + (L + { T17544_kw.hs:13:3-11 } {ModuleName: T17544_kw})) (Nothing) [] - [({ T17544_kw.hs:(15,1)-(16,20) } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544_kw.hs:(15,1)-(16,20) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544_kw.hs:(15,1)-(16,20) }) (TyClD (NoExtField) (DataDecl - (NoExtField) - ({ T17544_kw.hs:15:6-8 } + (ApiAnn + (Anchor + { T17544_kw.hs:(15,1)-(16,20) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544_kw.hs:15:1-4 })) + ,(AddApiAnn AnnWhere (AR { T17544_kw.hs:16:3-7 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:15:6-8 }) (Unqual {OccName: Foo})) (HsQTvs @@ -23,42 +63,82 @@ []) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:(15,1)-(16,20) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T17544_kw.hs:15:1-4 })) + ,(AddApiAnn AnnWhere (AR { T17544_kw.hs:16:3-7 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T17544_kw.hs:16:9-20 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:16:9-20 }) (ConDeclGADT - (NoExtField) - [({ T17544_kw.hs:16:9-13 } + (ApiAnn + (Anchor + { T17544_kw.hs:16:9-20 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544_kw.hs:16:15-16 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:16:9-13 }) (Unqual {OccName: MkFoo}))] - ({ T17544_kw.hs:16:18-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:16:18-20 }) (HsOuterImplicit (NoExtField))) (Nothing) (PrefixConGADT []) - ({ T17544_kw.hs:16:18-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:16:18-20 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:16:18-20 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544_kw.hs:16:18-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:16:18-20 }) (Unqual {OccName: Foo})))) (Just - ({ T17544_kw.hs:15:10-35 } + (L + { T17544_kw.hs:15:10-35 } (HsDocString " Bad comment for MkFoo")))))] - ({ <no location info> } - []))))) - ,({ T17544_kw.hs:(18,1)-(19,26) } + [])))) + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544_kw.hs:(18,1)-(19,26) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544_kw.hs:(18,1)-(19,26) }) (TyClD (NoExtField) (DataDecl - (NoExtField) - ({ T17544_kw.hs:18:9-11 } + (ApiAnn + (Anchor + { T17544_kw.hs:(18,1)-(19,26) } + (UnchangedAnchor)) + [(AddApiAnn AnnNewtype (AR { T17544_kw.hs:18:1-7 })) + ,(AddApiAnn AnnWhere (AR { T17544_kw.hs:19:3-7 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:18:9-11 }) (Unqual {OccName: Bar})) (HsQTvs @@ -66,18 +146,34 @@ []) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:(18,1)-(19,26) } + (UnchangedAnchor)) + [(AddApiAnn AnnNewtype (AR { T17544_kw.hs:18:1-7 })) + ,(AddApiAnn AnnWhere (AR { T17544_kw.hs:19:3-7 }))] + (AnnComments + [])) (NewType) (Nothing) (Nothing) (Nothing) - [({ T17544_kw.hs:19:9-26 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:19:9-26 }) (ConDeclGADT - (NoExtField) - [({ T17544_kw.hs:19:9-13 } + (ApiAnn + (Anchor + { T17544_kw.hs:19:9-26 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T17544_kw.hs:19:15-16 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:19:9-13 }) (Unqual {OccName: MkBar}))] - ({ T17544_kw.hs:19:18-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:19:18-26 }) (HsOuterImplicit (NoExtField))) (Nothing) @@ -85,76 +181,148 @@ [(HsScaled (HsUnrestrictedArrow (NormalSyntax)) - ({ T17544_kw.hs:19:18-19 } + (L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544_kw.hs:19:18-19 } + (UnchangedAnchor)) + (AnnListItem + [(AddRarrowAnn + (AR { T17544_kw.hs:19:21-22 }))]) + (AnnComments + [])) { T17544_kw.hs:19:18-19 }) (HsTupleTy - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:19:18 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { T17544_kw.hs:19:18 }) + (AR { T17544_kw.hs:19:19 })) + (AnnComments + [])) (HsBoxedOrConstraintTuple) [])))]) - ({ T17544_kw.hs:19:24-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:19:24-26 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:19:24-26 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544_kw.hs:19:24-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:19:24-26 }) (Unqual {OccName: Bar})))) (Just - ({ T17544_kw.hs:18:13-38 } + (L + { T17544_kw.hs:18:13-38 } (HsDocString " Bad comment for MkBar")))))] - ({ <no location info> } - []))))) - ,({ T17544_kw.hs:(21,1)-(24,18) } + [])))) + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T17544_kw.hs:(21,1)-(24,18) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T17544_kw.hs:(21,1)-(24,18) }) (TyClD (NoExtField) (ClassDecl - (VirtualBraces - (5)) + ((,,) + (ApiAnn + (Anchor + { T17544_kw.hs:(21,1)-(24,18) } + (UnchangedAnchor)) + [(AddApiAnn AnnClass (AR { T17544_kw.hs:21:1-5 })) + ,(AddApiAnn AnnWhere (AR { T17544_kw.hs:23:3-7 }))] + (AnnComments + [])) + (NoAnnSortKey) + (VirtualBraces + (5))) (Nothing) - ({ T17544_kw.hs:21:7-9 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:21:7-9 }) (Unqual {OccName: Cls})) (HsQTvs (NoExtField) - [({ T17544_kw.hs:21:11 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:21:11 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:21:11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T17544_kw.hs:21:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:21:11 }) (Unqual {OccName: a}))))]) (Prefix) [] - [({ T17544_kw.hs:24:5-18 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:24:5-18 }) (ClassOpSig - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:24:5-13 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { T17544_kw.hs:24:15-16 })) + []) + (AnnComments + [])) (False) - [({ T17544_kw.hs:24:5-13 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:24:5-13 }) (Unqual {OccName: clsmethod}))] - ({ T17544_kw.hs:24:18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:24:18 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ T17544_kw.hs:24:18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:24:18 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T17544_kw.hs:24:18 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T17544_kw.hs:24:18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:24:18 }) (Unqual {OccName: a}))))))))] - {Bag(Located (HsBind GhcPs)): + {Bag(LocatedA (HsBind GhcPs)): []} [] [] - [({ T17544_kw.hs:22:5-34 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T17544_kw.hs:22:5-34 }) (DocCommentNext (HsDocString " Bad comment for clsmethod")))])))] (Nothing) (Just - ({ T17544_kw.hs:12:3-33 } + (L + { T17544_kw.hs:12:3-33 } (HsDocString " Bad comment for the module"))))) - - diff --git a/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr b/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr index 44dc9475c0..46d8c43ddc 100644 --- a/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr +++ b/testsuite/tests/indexed-types/should_fail/GADTwrong1.stderr @@ -11,7 +11,7 @@ GADTwrong1.hs:12:21: error: at GADTwrong1.hs:10:1-29 • In the expression: y In a case alternative: T y -> y - In the expression: case T x :: T (Const b) of { T y -> y } + In the expression: case T x :: T (Const b) of T y -> y • Relevant bindings include y :: c (bound at GADTwrong1.hs:12:16) coerce :: a -> b (bound at GADTwrong1.hs:11:1) diff --git a/testsuite/tests/indexed-types/should_fail/T9554.stderr b/testsuite/tests/indexed-types/should_fail/T9554.stderr index b62badda9d..2b4bf82a6e 100644 --- a/testsuite/tests/indexed-types/should_fail/T9554.stderr +++ b/testsuite/tests/indexed-types/should_fail/T9554.stderr @@ -21,4 +21,4 @@ T9554.hs:13:17: error: • In the first argument of ‘foo’, namely ‘Proxy’ In the expression: foo Proxy In the expression: - case foo Proxy of { Proxy -> putStrLn "Made it!" } + case foo Proxy of Proxy -> putStrLn "Made it!" diff --git a/testsuite/tests/linear/should_fail/Linear13.stderr b/testsuite/tests/linear/should_fail/Linear13.stderr index a781c20da6..4e8603c3e3 100644 --- a/testsuite/tests/linear/should_fail/Linear13.stderr +++ b/testsuite/tests/linear/should_fail/Linear13.stderr @@ -25,4 +25,4 @@ Linear13.hs:15:24: error: • Couldn't match type ‘'Many’ with ‘'One’ arising from multiplicity of ‘x’ • In an equation for ‘incorrectCasePromotion’: - incorrectCasePromotion x = case x of { (a, b) -> b } + incorrectCasePromotion x = case x of (a, b) -> b diff --git a/testsuite/tests/linear/should_fail/LinearBottomMult.stderr b/testsuite/tests/linear/should_fail/LinearBottomMult.stderr index fd846070d8..11ee3d10fd 100644 --- a/testsuite/tests/linear/should_fail/LinearBottomMult.stderr +++ b/testsuite/tests/linear/should_fail/LinearBottomMult.stderr @@ -3,4 +3,4 @@ LinearBottomMult.hs:13:3: error: • Couldn't match type ‘'Many’ with ‘'One’ arising from multiplicity of ‘x’ • In an equation for ‘f’: - f x = elim (U (\ (a :: Void) -> case a of)) + f x = elim (U (\ (a :: Void) -> case a of {})) diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr index f2bb93c3e9..73a5ecab16 100644 --- a/testsuite/tests/module/mod185.stderr +++ b/testsuite/tests/module/mod185.stderr @@ -1,16 +1,54 @@ + ==================== Parser AST ==================== -({ mod185.hs:1:1 } +(L + { mod185.hs:1:1 } (HsModule + (ApiAnn + (Anchor + { mod185.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { mod185.hs:6:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { mod185.hs:6:1 }))])) (VirtualBraces (1)) (Nothing) (Nothing) - [({ mod185.hs:3:1-24 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { mod185.hs:3:1-24 }) (ImportDecl - (NoExtField) + (ApiAnn + (Anchor + { mod185.hs:3:1-6 } + (UnchangedAnchor)) + (ApiAnnImportDecl + (AR { mod185.hs:3:1-6 }) + (Nothing) + (Nothing) + (Just + (AR { mod185.hs:3:16-24 })) + (Nothing) + (Nothing)) + (AnnComments + [])) (NoSourceText) - ({ mod185.hs:3:8-14 } + (L + { mod185.hs:3:8-14 } {ModuleName: Prelude}) (Nothing) (NotBoot) @@ -19,22 +57,40 @@ (False) (Nothing) (Nothing)))] - [({ mod185.hs:5:1-24 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { mod185.hs:5:1-24 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { mod185.hs:5:1-24 }) (ValD (NoExtField) (FunBind (NoExtField) - ({ mod185.hs:5:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { mod185.hs:5:1-4 }) (Unqual {OccName: main})) (MG (NoExtField) - ({ mod185.hs:5:1-24 } - [({ mod185.hs:5:1-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { mod185.hs:5:1-24 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { mod185.hs:5:1-24 }) (Match - (NoExtField) + (ApiAnn + (Anchor + { mod185.hs:5:1-24 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (FunRhs - ({ mod185.hs:5:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { mod185.hs:5:1-4 }) (Unqual {OccName: main})) (Prefix) @@ -42,20 +98,30 @@ [] (GRHSs (NoExtField) - [({ mod185.hs:5:6-24 } + [(L + { mod185.hs:5:6-24 } (GRHS - (NoExtField) + (ApiAnn + (Anchor + { mod185.hs:5:6-24 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddApiAnn AnnEqual (AR { mod185.hs:5:6 }))) + (AnnComments + [])) [] - ({ mod185.hs:5:8-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { mod185.hs:5:8-24 }) (HsVar (NoExtField) - ({ mod185.hs:5:8-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { mod185.hs:5:8-24 }) (Qual {ModuleName: Prelude} {OccName: undefined}))))))] - ({ <no location info> } - (EmptyLocalBinds - (NoExtField))))))]) + (EmptyLocalBinds + (NoExtField)))))]) (FromSource)) [])))] (Nothing) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 640adcb50b..9c6885620d 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -1,19 +1,57 @@ ==================== Parser AST ==================== -({ DumpParsedAst.hs:1:1 } +(L + { DumpParsedAst.hs:1:1 } (HsModule + (ApiAnn + (Anchor + { DumpParsedAst.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddApiAnn AnnModule (AR { DumpParsedAst.hs:5:1-6 })) + ,(AddApiAnn AnnWhere (AR { DumpParsedAst.hs:5:22-26 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { DumpParsedAst.hs:21:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { DumpParsedAst.hs:21:1 }))])) (VirtualBraces (1)) (Just - ({ DumpParsedAst.hs:5:8-20 } + (L + { DumpParsedAst.hs:5:8-20 } {ModuleName: DumpParsedAst})) (Nothing) - [({ DumpParsedAst.hs:6:1-16 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:6:1-16 }) (ImportDecl - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:6:1-6 } + (UnchangedAnchor)) + (ApiAnnImportDecl + (AR { DumpParsedAst.hs:6:1-6 }) + (Nothing) + (Nothing) + (Nothing) + (Nothing) + (Nothing)) + (AnnComments + [])) (NoSourceText) - ({ DumpParsedAst.hs:6:8-16 } + (L + { DumpParsedAst.hs:6:8-16 } {ModuleName: Data.Kind}) (Nothing) (NotBoot) @@ -22,12 +60,28 @@ (False) (Nothing) (Nothing)))] - [({ DumpParsedAst.hs:8:1-30 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpParsedAst.hs:8:1-30 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpParsedAst.hs:8:1-30 }) (TyClD (NoExtField) (DataDecl - (NoExtField) - ({ DumpParsedAst.hs:8:6-10 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:8:1-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { DumpParsedAst.hs:8:1-4 })) + ,(AddApiAnn AnnEqual (AR { DumpParsedAst.hs:8:12 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:8:6-10 }) (Unqual {OccName: Peano})) (HsQTvs @@ -35,407 +89,855 @@ []) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:8:1-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { DumpParsedAst.hs:8:1-4 })) + ,(AddApiAnn AnnEqual (AR { DumpParsedAst.hs:8:12 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ DumpParsedAst.hs:8:14-17 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpParsedAst.hs:8:14-17 } + (UnchangedAnchor)) + (AnnListItem + [(AddVbarAnn + (AR { DumpParsedAst.hs:8:19 }))]) + (AnnComments + [])) { DumpParsedAst.hs:8:14-17 }) (ConDeclH98 - (NoExtField) - ({ DumpParsedAst.hs:8:14-17 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:8:14-17 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:8:14-17 }) (Unqual {OccName: Zero})) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] []) (Nothing))) - ,({ DumpParsedAst.hs:8:21-30 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:8:21-30 }) (ConDeclH98 - (NoExtField) - ({ DumpParsedAst.hs:8:21-24 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:8:21-30 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:8:21-24 }) (Unqual {OccName: Succ})) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] [(HsScaled (HsLinearArrow - (NormalSyntax)) - ({ DumpParsedAst.hs:8:26-30 } + (NormalSyntax) + (Nothing)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:8:26-30 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:8:26-30 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:8:26-30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:8:26-30 }) (Unqual {OccName: Peano})))))]) (Nothing)))] - ({ <no location info> } - []))))) - ,({ DumpParsedAst.hs:10:1-39 } + [])))) + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpParsedAst.hs:10:1-39 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpParsedAst.hs:10:1-39 }) (TyClD (NoExtField) (FamDecl (NoExtField) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:10:1-45 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { DumpParsedAst.hs:10:1-4 })) + ,(AddApiAnn AnnFamily (AR { DumpParsedAst.hs:10:6-11 })) + ,(AddApiAnn AnnDcolon (AR { DumpParsedAst.hs:10:32-33 })) + ,(AddApiAnn AnnWhere (AR { DumpParsedAst.hs:10:41-45 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:10:30 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:10:20 }))] + (AnnComments + [])) (ClosedTypeFamily (Just - [({ DumpParsedAst.hs:11:3-36 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:3-36 }) (FamEqn - (NoExtField) - ({ DumpParsedAst.hs:11:3-8 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:3-36 } + (UnchangedAnchor)) + [(AddApiAnn AnnEqual (AR { DumpParsedAst.hs:11:19 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:3-8 }) (Unqual {OccName: Length})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ DumpParsedAst.hs:11:10-17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:10-17 }) (HsParTy - (NoExtField) - ({ DumpParsedAst.hs:11:11-16 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:10 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { DumpParsedAst.hs:11:10 }) + (AR { DumpParsedAst.hs:11:17 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:11-16 }) (HsOpTy (NoExtField) - ({ DumpParsedAst.hs:11:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:11:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:11 }) (Unqual {OccName: a})))) - ({ DumpParsedAst.hs:11:13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:13 }) (Exact {Name: :})) - ({ DumpParsedAst.hs:11:15-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:15-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:15-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:11:15-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:15-16 }) (Unqual {OccName: as})))))))))] (Prefix) - ({ DumpParsedAst.hs:11:21-36 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:21-36 }) (HsAppTy (NoExtField) - ({ DumpParsedAst.hs:11:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:21-24 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:21-24 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:11:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:21-24 }) (Unqual {OccName: Succ})))) - ({ DumpParsedAst.hs:11:26-36 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:26-36 }) (HsParTy - (NoExtField) - ({ DumpParsedAst.hs:11:27-35 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:26 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { DumpParsedAst.hs:11:26 }) + (AR { DumpParsedAst.hs:11:36 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:27-35 }) (HsAppTy (NoExtField) - ({ DumpParsedAst.hs:11:27-32 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:27-32 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:27-32 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:11:27-32 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:27-32 }) (Unqual {OccName: Length})))) - ({ DumpParsedAst.hs:11:34-35 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:34-35 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:11:34-35 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:11:34-35 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:11:34-35 }) (Unqual {OccName: as})))))))))))) - ,({ DumpParsedAst.hs:12:3-24 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:12:3-24 }) (FamEqn - (NoExtField) - ({ DumpParsedAst.hs:12:3-8 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:12:3-24 } + (UnchangedAnchor)) + [(AddApiAnn AnnEqual (AR { DumpParsedAst.hs:12:19 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:12:3-8 }) (Unqual {OccName: Length})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ DumpParsedAst.hs:12:10-12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:12:10-12 }) (HsExplicitListTy - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:12:10 } + (UnchangedAnchor)) + [(AddApiAnn AnnSimpleQuote (AR { DumpParsedAst.hs:12:10 })) + ,(AddApiAnn AnnOpenS (AR { DumpParsedAst.hs:12:11 })) + ,(AddApiAnn AnnCloseS (AR { DumpParsedAst.hs:12:12 }))] + (AnnComments + [])) (IsPromoted) [])))] (Prefix) - ({ DumpParsedAst.hs:12:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:12:21-24 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:12:21-24 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:12:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:12:21-24 }) (Unqual {OccName: Zero}))))))])) - ({ DumpParsedAst.hs:10:13-18 } + (TopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:13-18 }) (Unqual {OccName: Length})) (HsQTvs (NoExtField) - [({ DumpParsedAst.hs:10:21-29 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:20-30 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:10:20-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpParsedAst.hs:10:24-25 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:10:20 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:10:30 }))] + (AnnComments + [])) (()) - ({ DumpParsedAst.hs:10:21-22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:21-22 }) (Unqual {OccName: as})) - ({ DumpParsedAst.hs:10:27-29 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:27-29 }) (HsListTy - (NoExtField) - ({ DumpParsedAst.hs:10:28 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:10:27 } + (UnchangedAnchor)) + (AnnParen + (AnnParensSquare) + (AR { DumpParsedAst.hs:10:27 }) + (AR { DumpParsedAst.hs:10:29 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:28 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:10:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:10:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:28 }) (Unqual {OccName: k}))))))))]) (Prefix) - ({ DumpParsedAst.hs:10:32-39 } + (L + { DumpParsedAst.hs:10:32-39 } (KindSig (NoExtField) - ({ DumpParsedAst.hs:10:35-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:35-39 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:10:35-39 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:10:35-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:10:35-39 }) (Unqual {OccName: Peano})))))) (Nothing))))) - ,({ DumpParsedAst.hs:15:1-29 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpParsedAst.hs:15:1-29 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpParsedAst.hs:15:1-29 }) (TyClD (NoExtField) (DataDecl - (NoExtField) - ({ DumpParsedAst.hs:15:6 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:1-29 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { DumpParsedAst.hs:15:1-4 })) + ,(AddApiAnn AnnEqual (AR { DumpParsedAst.hs:15:19 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:15:17 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:15:10 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:6 }) (Unqual {OccName: T})) (HsQTvs (NoExtField) - [({ DumpParsedAst.hs:15:8 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:8 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:8 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ DumpParsedAst.hs:15:8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:8 }) (Unqual {OccName: f})))) - ,({ DumpParsedAst.hs:15:11-16 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:10-17 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:10-17 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpParsedAst.hs:15:13-14 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:15:10 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:15:17 }))] + (AnnComments + [])) (()) - ({ DumpParsedAst.hs:15:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:11 }) (Unqual {OccName: a})) - ({ DumpParsedAst.hs:15:16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:15:16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:16 }) (Unqual {OccName: k}))))))]) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:1-29 } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { DumpParsedAst.hs:15:1-4 })) + ,(AddApiAnn AnnEqual (AR { DumpParsedAst.hs:15:19 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:15:17 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:15:10 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ DumpParsedAst.hs:15:21-29 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:21-29 }) (ConDeclH98 - (NoExtField) - ({ DumpParsedAst.hs:15:21-23 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:21-29 } + (UnchangedAnchor)) + [] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:21-23 }) (Unqual {OccName: MkT})) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] [(HsScaled (HsLinearArrow - (NormalSyntax)) - ({ DumpParsedAst.hs:15:25-29 } + (NormalSyntax) + (Nothing)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:25-29 }) (HsParTy - (NoExtField) - ({ DumpParsedAst.hs:15:26-28 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:25 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { DumpParsedAst.hs:15:25 }) + (AR { DumpParsedAst.hs:15:29 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:26-28 }) (HsAppTy (NoExtField) - ({ DumpParsedAst.hs:15:26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:26 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:26 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:15:26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:26 }) (Unqual {OccName: f})))) - ({ DumpParsedAst.hs:15:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:28 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:15:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:15:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:15:28 }) (Unqual {OccName: a})))))))))]) (Nothing)))] - ({ <no location info> } - []))))) - ,({ DumpParsedAst.hs:17:1-48 } + [])))) + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpParsedAst.hs:17:1-48 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpParsedAst.hs:17:1-48 }) (TyClD (NoExtField) (FamDecl (NoExtField) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:1-54 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { DumpParsedAst.hs:17:1-4 })) + ,(AddApiAnn AnnFamily (AR { DumpParsedAst.hs:17:6-11 })) + ,(AddApiAnn AnnDcolon (AR { DumpParsedAst.hs:17:42-43 })) + ,(AddApiAnn AnnWhere (AR { DumpParsedAst.hs:17:50-54 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:17:23 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:17:16 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:17:40 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:17:25 }))] + (AnnComments + [])) (ClosedTypeFamily (Just - [({ DumpParsedAst.hs:18:3-30 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:3-30 }) (FamEqn - (NoExtField) - ({ DumpParsedAst.hs:18:3-4 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:3-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnEqual (AR { DumpParsedAst.hs:18:17 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:3-4 }) (Unqual {OccName: F1})) (HsOuterImplicit (NoExtField)) [(HsTypeArg - { DumpParsedAst.hs:18:6-11 } - ({ DumpParsedAst.hs:18:7-11 } + { DumpParsedAst.hs:18:6 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:7-11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:7-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:18:7-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:7-11 }) (Unqual {OccName: Peano}))))) ,(HsValArg - ({ DumpParsedAst.hs:18:13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:18:13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:13 }) (Unqual {OccName: a}))))) ,(HsValArg - ({ DumpParsedAst.hs:18:15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:15 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:15 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:18:15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:15 }) (Unqual {OccName: f})))))] (Prefix) - ({ DumpParsedAst.hs:18:19-30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:19-30 }) (HsAppTy (NoExtField) - ({ DumpParsedAst.hs:18:19-28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:19-28 }) (HsAppTy (NoExtField) - ({ DumpParsedAst.hs:18:19-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:19-26 }) (HsAppKindTy - { DumpParsedAst.hs:18:21-26 } - ({ DumpParsedAst.hs:18:19 } + { DumpParsedAst.hs:18:21 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:19 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:19 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:18:19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:19 }) (Unqual {OccName: T})))) - ({ DumpParsedAst.hs:18:22-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:22-26 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:22-26 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:18:22-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:22-26 }) (Unqual {OccName: Peano})))))) - ({ DumpParsedAst.hs:18:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:28 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:18:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:28 }) (Unqual {OccName: f})))))) - ({ DumpParsedAst.hs:18:30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:30 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:18:30 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:18:30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:18:30 }) (Unqual {OccName: a}))))))))])) - ({ DumpParsedAst.hs:17:13-14 } + (TopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:13-14 }) (Unqual {OccName: F1})) (HsQTvs (NoExtField) - [({ DumpParsedAst.hs:17:17-22 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:16-23 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:16-23 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpParsedAst.hs:17:19-20 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:17:16 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:17:23 }))] + (AnnComments + [])) (()) - ({ DumpParsedAst.hs:17:17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:17 }) (Unqual {OccName: a})) - ({ DumpParsedAst.hs:17:22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:22 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:22 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:17:22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:22 }) (Unqual {OccName: k})))))) - ,({ DumpParsedAst.hs:17:26-39 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:25-40 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:25-40 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpParsedAst.hs:17:28-29 })) + ,(AddApiAnn AnnOpenP (AR { DumpParsedAst.hs:17:25 })) + ,(AddApiAnn AnnCloseP (AR { DumpParsedAst.hs:17:40 }))] + (AnnComments + [])) (()) - ({ DumpParsedAst.hs:17:26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:26 }) (Unqual {OccName: f})) - ({ DumpParsedAst.hs:17:31-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:31-39 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:31 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpParsedAst.hs:17:33-34 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpParsedAst.hs:17:31 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:31 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:31 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:17:31 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:31 }) (Unqual {OccName: k})))) - ({ DumpParsedAst.hs:17:36-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:36-39 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:36-39 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:17:36-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:36-39 }) (Unqual {OccName: Type}))))))))]) (Prefix) - ({ DumpParsedAst.hs:17:42-48 } + (L + { DumpParsedAst.hs:17:42-48 } (KindSig (NoExtField) - ({ DumpParsedAst.hs:17:45-48 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:45-48 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:17:45-48 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ DumpParsedAst.hs:17:45-48 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:17:45-48 }) (Unqual {OccName: Type})))))) (Nothing))))) - ,({ DumpParsedAst.hs:20:1-23 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpParsedAst.hs:20:1-23 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpParsedAst.hs:20:1-23 }) (ValD (NoExtField) (FunBind (NoExtField) - ({ DumpParsedAst.hs:20:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:1-4 }) (Unqual {OccName: main})) (MG (NoExtField) - ({ DumpParsedAst.hs:20:1-23 } - [({ DumpParsedAst.hs:20:1-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:1-23 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:1-23 }) (Match - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:20:1-23 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (FunRhs - ({ DumpParsedAst.hs:20:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:1-4 }) (Unqual {OccName: main})) (Prefix) @@ -443,32 +945,53 @@ [] (GRHSs (NoExtField) - [({ DumpParsedAst.hs:20:6-23 } + [(L + { DumpParsedAst.hs:20:6-23 } (GRHS - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:20:6-23 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddApiAnn AnnEqual (AR { DumpParsedAst.hs:20:6 }))) + (AnnComments + [])) [] - ({ DumpParsedAst.hs:20:8-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:8-23 }) (HsApp - (NoExtField) - ({ DumpParsedAst.hs:20:8-15 } + (ApiAnn + (Anchor + { DumpParsedAst.hs:20:8-23 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:8-15 }) (HsVar (NoExtField) - ({ DumpParsedAst.hs:20:8-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:8-15 }) (Unqual {OccName: putStrLn})))) - ({ DumpParsedAst.hs:20:17-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpParsedAst.hs:20:17-23 }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { DumpParsedAst.hs:20:17-23 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsString - (SourceText - "\"hello\"") + (SourceText "hello") {FastString: "hello"})))))))] - ({ <no location info> } - (EmptyLocalBinds - (NoExtField))))))]) + (EmptyLocalBinds + (NoExtField)))))]) (FromSource)) [])))] (Nothing) (Nothing))) - - diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index ec4c1dd9bd..cbed41c027 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -9,226 +9,332 @@ (NValBinds [((,) (NonRecursive) - {Bag(Located (HsBind Name)): - [({ DumpRenamedAst.hs:27:1-23 } + {Bag(LocatedA (HsBind Name)): + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:27:1-23 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpRenamedAst.hs:27:1-23 }) (FunBind {NameSet: []} - ({ DumpRenamedAst.hs:27:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:1-4 }) {Name: DumpRenamedAst.main}) (MG (NoExtField) - ({ DumpRenamedAst.hs:27:1-23 } - [({ DumpRenamedAst.hs:27:1-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:1-23 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:1-23 }) (Match - (NoExtField) + (ApiAnnNotUsed) (FunRhs - ({ DumpRenamedAst.hs:27:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:1-4 }) {Name: DumpRenamedAst.main}) (Prefix) (NoSrcStrict)) [] (GRHSs (NoExtField) - [({ DumpRenamedAst.hs:27:6-23 } + [(L + { DumpRenamedAst.hs:27:6-23 } (GRHS - (NoExtField) + (ApiAnnNotUsed) [] - ({ DumpRenamedAst.hs:27:8-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:8-23 }) (HsApp - (NoExtField) - ({ DumpRenamedAst.hs:27:8-15 } + (ApiAnn + (Anchor + { DumpRenamedAst.hs:27:8-23 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:8-15 }) (HsVar (NoExtField) - ({ DumpRenamedAst.hs:27:8-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:8-15 }) {Name: System.IO.putStrLn}))) - ({ DumpRenamedAst.hs:27:17-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:27:17-23 }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:27:17-23 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsString - (SourceText - "\"hello\"") + (SourceText "hello") {FastString: "hello"})))))))] - ({ <no location info> } - (EmptyLocalBinds - (NoExtField))))))]) + (EmptyLocalBinds + (NoExtField)))))]) (FromSource)) []))]})] [])) [] [(TyClGroup (NoExtField) - [({ DumpRenamedAst.hs:10:1-30 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:10:1-30 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpRenamedAst.hs:10:1-30 }) (DataDecl (DataDeclRn (True) {NameSet: [{Name: DumpRenamedAst.Peano}]}) - ({ DumpRenamedAst.hs:10:6-10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:10:6-10 }) {Name: DumpRenamedAst.Peano}) (HsQTvs [] []) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnnNotUsed) (DataType) (Nothing) (Nothing) (Nothing) - [({ DumpRenamedAst.hs:10:14-17 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:10:14-17 } + (UnchangedAnchor)) + (AnnListItem + [(AddVbarAnn + (AR { DumpRenamedAst.hs:10:19 }))]) + (AnnComments + [])) { DumpRenamedAst.hs:10:14-17 }) (ConDeclH98 - (NoExtField) - ({ DumpRenamedAst.hs:10:14-17 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:10:14-17 }) {Name: DumpRenamedAst.Zero}) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] []) (Nothing))) - ,({ DumpRenamedAst.hs:10:21-30 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:10:21-30 }) (ConDeclH98 - (NoExtField) - ({ DumpRenamedAst.hs:10:21-24 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:10:21-24 }) {Name: DumpRenamedAst.Succ}) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] [(HsScaled (HsLinearArrow - (NormalSyntax)) - ({ DumpRenamedAst.hs:10:26-30 } + (NormalSyntax) + (Nothing)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:10:26-30 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:10:26-30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:10:26-30 }) {Name: DumpRenamedAst.Peano}))))]) (Nothing)))] - ({ <no location info> } - []))))] + [])))] [] [] []) ,(TyClGroup (NoExtField) - [({ DumpRenamedAst.hs:12:1-39 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:12:1-39 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpRenamedAst.hs:12:1-39 }) (FamDecl (NoExtField) (FamilyDecl - (NoExtField) + (ApiAnnNotUsed) (ClosedTypeFamily (Just - [({ DumpRenamedAst.hs:13:3-36 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:3-36 }) (FamEqn - (NoExtField) - ({ DumpRenamedAst.hs:13:3-8 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:3-8 }) {Name: DumpRenamedAst.Length}) (HsOuterImplicit [{Name: a} ,{Name: as}]) [(HsValArg - ({ DumpRenamedAst.hs:13:10-17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:10-17 }) (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:13:11-16 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:11-16 }) (HsOpTy (NoExtField) - ({ DumpRenamedAst.hs:13:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:11 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:13:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:11 }) {Name: a}))) - ({ DumpRenamedAst.hs:13:13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:13 }) {Name: :}) - ({ DumpRenamedAst.hs:13:15-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:15-16 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:13:15-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:15-16 }) {Name: as}))))))))] (Prefix) - ({ DumpRenamedAst.hs:13:21-36 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:21-36 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:13:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:21-24 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:13:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:21-24 }) {Name: DumpRenamedAst.Succ}))) - ({ DumpRenamedAst.hs:13:26-36 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:26-36 }) (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:13:27-35 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:27-35 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:13:27-32 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:27-32 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:13:27-32 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:27-32 }) {Name: DumpRenamedAst.Length}))) - ({ DumpRenamedAst.hs:13:34-35 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:34-35 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:13:34-35 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:13:34-35 }) {Name: as}))))))))))) - ,({ DumpRenamedAst.hs:14:3-24 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:14:3-24 }) (FamEqn - (NoExtField) - ({ DumpRenamedAst.hs:14:3-8 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:14:3-8 }) {Name: DumpRenamedAst.Length}) (HsOuterImplicit []) [(HsValArg - ({ DumpRenamedAst.hs:14:10-12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:14:10-12 }) (HsExplicitListTy (NoExtField) (IsPromoted) [])))] (Prefix) - ({ DumpRenamedAst.hs:14:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:14:21-24 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:14:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:14:21-24 }) {Name: DumpRenamedAst.Zero})))))])) - ({ DumpRenamedAst.hs:12:13-18 } + (TopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:13-18 }) {Name: DumpRenamedAst.Length}) (HsQTvs [{Name: k}] - [({ DumpRenamedAst.hs:12:21-29 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:20-30 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:12:20-30 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpRenamedAst.hs:12:24-25 })) + ,(AddApiAnn AnnOpenP (AR { DumpRenamedAst.hs:12:20 })) + ,(AddApiAnn AnnCloseP (AR { DumpRenamedAst.hs:12:30 }))] + (AnnComments + [])) (()) - ({ DumpRenamedAst.hs:12:21-22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:21-22 }) {Name: as}) - ({ DumpRenamedAst.hs:12:27-29 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:27-29 }) (HsListTy - (NoExtField) - ({ DumpRenamedAst.hs:12:28 } + (ApiAnn + (Anchor + { DumpRenamedAst.hs:12:27 } + (UnchangedAnchor)) + (AnnParen + (AnnParensSquare) + (AR { DumpRenamedAst.hs:12:27 }) + (AR { DumpRenamedAst.hs:12:29 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:28 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:12:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:28 }) {Name: k})))))))]) (Prefix) - ({ DumpRenamedAst.hs:12:32-39 } + (L + { DumpRenamedAst.hs:12:32-39 } (KindSig (NoExtField) - ({ DumpRenamedAst.hs:12:35-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:35-39 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:12:35-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:12:35-39 }) {Name: DumpRenamedAst.Peano}))))) (Nothing))))] [] @@ -236,137 +342,227 @@ []) ,(TyClGroup (NoExtField) - [({ DumpRenamedAst.hs:16:1-33 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:16:1-33 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpRenamedAst.hs:16:1-33 }) (FamDecl (NoExtField) (FamilyDecl - (NoExtField) + (ApiAnnNotUsed) (DataFamily) - ({ DumpRenamedAst.hs:16:13-15 } + (TopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:13-15 }) {Name: DumpRenamedAst.Nat}) (HsQTvs [{Name: k}] []) (Prefix) - ({ DumpRenamedAst.hs:16:17-33 } + (L + { DumpRenamedAst.hs:16:17-33 } (KindSig (NoExtField) - ({ DumpRenamedAst.hs:16:20-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:20-33 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:16:20 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpRenamedAst.hs:16:22-23 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:16:20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:20 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:16:20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:20 }) {Name: k}))) - ({ DumpRenamedAst.hs:16:25-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:25-33 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:16:25 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpRenamedAst.hs:16:27-28 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:16:25 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:25 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:16:25 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:25 }) {Name: k}))) - ({ DumpRenamedAst.hs:16:30-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:30-33 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:16:30-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:16:30-33 }) {Name: GHC.Types.Type}))))))))) (Nothing))))] [] [] - [({ DumpRenamedAst.hs:(19,1)-(20,45) } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:(19,1)-(20,45) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpRenamedAst.hs:(19,1)-(20,45) }) (DataFamInstD (NoExtField) (DataFamInstDecl (FamEqn - (NoExtField) - ({ DumpRenamedAst.hs:19:18-20 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:18-20 }) {Name: DumpRenamedAst.Nat}) (HsOuterImplicit [{Name: a} ,{Name: k}]) [(HsValArg - ({ DumpRenamedAst.hs:19:22-37 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:22-37 }) (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:19:23-36 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:23-36 }) (HsKindSig - (NoExtField) - ({ DumpRenamedAst.hs:19:23 } + (ApiAnn + (Anchor + { DumpRenamedAst.hs:19:23 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpRenamedAst.hs:19:25-26 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:23 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:19:23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:23 }) {Name: a}))) - ({ DumpRenamedAst.hs:19:28-36 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:28-36 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:19:28 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpRenamedAst.hs:19:30-31 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:19:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:28 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:19:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:28 }) {Name: k}))) - ({ DumpRenamedAst.hs:19:33-36 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:33-36 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:19:33-36 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:33-36 }) {Name: GHC.Types.Type}))))))))))] (Prefix) (HsDataDefn - (NoExtField) + (ApiAnnNotUsed) (NewType) (Nothing) (Nothing) (Just - ({ DumpRenamedAst.hs:19:42-60 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:42-60 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:19:42-52 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpRenamedAst.hs:19:54-55 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:19:42-52 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:42-52 }) (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:19:43-51 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:43-51 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:19:43 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpRenamedAst.hs:19:45-46 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:19:43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:43 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:19:43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:43 }) {Name: k}))) - ({ DumpRenamedAst.hs:19:48-51 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:48-51 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:19:48-51 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:48-51 }) {Name: GHC.Types.Type}))))))) - ({ DumpRenamedAst.hs:19:57-60 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:57-60 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:19:57-60 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:19:57-60 }) {Name: GHC.Types.Type})))))) - [({ DumpRenamedAst.hs:20:3-45 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:3-45 }) (ConDeclGADT - (NoExtField) - [({ DumpRenamedAst.hs:20:3-5 } + (ApiAnnNotUsed) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:3-5 }) {Name: DumpRenamedAst.Nat})] - ({ DumpRenamedAst.hs:20:10-45 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:10-45 }) (HsOuterImplicit [{Name: f} ,{Name: g}])) @@ -375,279 +571,424 @@ [(HsScaled (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:20:10-34 } + (L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:20:10-34 } + (UnchangedAnchor)) + (AnnListItem + [(AddRarrowAnn + (AR { DumpRenamedAst.hs:20:36-37 }))]) + (AnnComments + [])) { DumpRenamedAst.hs:20:10-34 }) (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:20:11-33 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:11-33 }) (HsForAllTy (NoExtField) (HsForAllInvis - (NoExtField) - [({ DumpRenamedAst.hs:20:18-19 } + (ApiAnnNotUsed) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:18-19 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:20:18-19 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (SpecifiedSpec) - ({ DumpRenamedAst.hs:20:18-19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:18-19 }) {Name: xx})))]) - ({ DumpRenamedAst.hs:20:22-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:22-33 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:20:22-25 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpRenamedAst.hs:20:27-28 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:20:22-25 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:22-25 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:20:22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:22 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:20:22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:22 }) {Name: f}))) - ({ DumpRenamedAst.hs:20:24-25 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:24-25 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:20:24-25 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:24-25 }) {Name: xx}))))) - ({ DumpRenamedAst.hs:20:30-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:30-33 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:20:30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:30 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:20:30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:30 }) {Name: g}))) - ({ DumpRenamedAst.hs:20:32-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:32-33 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:20:32-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:32-33 }) {Name: xx}))))))))))))]) - ({ DumpRenamedAst.hs:20:39-45 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:39-45 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:20:39-43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:39-43 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:20:39-41 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:39-41 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:20:39-41 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:39-41 }) {Name: DumpRenamedAst.Nat}))) - ({ DumpRenamedAst.hs:20:43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:43 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:20:43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:43 }) {Name: f}))))) - ({ DumpRenamedAst.hs:20:45 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:45 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:20:45 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:20:45 }) {Name: g}))))) (Nothing)))] - ({ <no location info> } - []))))))]) + [])))))]) ,(TyClGroup (NoExtField) - [({ DumpRenamedAst.hs:22:1-29 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:22:1-29 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpRenamedAst.hs:22:1-29 }) (DataDecl (DataDeclRn (False) {NameSet: [{Name: a} ,{Name: f}]}) - ({ DumpRenamedAst.hs:22:6 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:6 }) {Name: DumpRenamedAst.T}) (HsQTvs [{Name: k}] - [({ DumpRenamedAst.hs:22:8 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:8 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:22:8 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ DumpRenamedAst.hs:22:8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:8 }) {Name: f}))) - ,({ DumpRenamedAst.hs:22:11-16 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:10-17 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:22:10-17 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpRenamedAst.hs:22:13-14 })) + ,(AddApiAnn AnnOpenP (AR { DumpRenamedAst.hs:22:10 })) + ,(AddApiAnn AnnCloseP (AR { DumpRenamedAst.hs:22:17 }))] + (AnnComments + [])) (()) - ({ DumpRenamedAst.hs:22:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:11 }) {Name: a}) - ({ DumpRenamedAst.hs:22:16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:16 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:22:16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:16 }) {Name: k})))))]) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnnNotUsed) (DataType) (Nothing) (Nothing) (Nothing) - [({ DumpRenamedAst.hs:22:21-29 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:21-29 }) (ConDeclH98 - (NoExtField) - ({ DumpRenamedAst.hs:22:21-23 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:21-23 }) {Name: DumpRenamedAst.MkT}) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] [(HsScaled (HsLinearArrow - (NormalSyntax)) - ({ DumpRenamedAst.hs:22:25-29 } + (NormalSyntax) + (Nothing)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:25-29 }) (HsParTy - (NoExtField) - ({ DumpRenamedAst.hs:22:26-28 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:26-28 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:22:26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:26 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:22:26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:26 }) {Name: f}))) - ({ DumpRenamedAst.hs:22:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:28 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:22:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:22:28 }) {Name: a}))))))))]) (Nothing)))] - ({ <no location info> } - []))))] + [])))] [] [] []) ,(TyClGroup (NoExtField) - [({ DumpRenamedAst.hs:24:1-48 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:24:1-48 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpRenamedAst.hs:24:1-48 }) (FamDecl (NoExtField) (FamilyDecl - (NoExtField) + (ApiAnnNotUsed) (ClosedTypeFamily (Just - [({ DumpRenamedAst.hs:25:3-30 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:3-30 }) (FamEqn - (NoExtField) - ({ DumpRenamedAst.hs:25:3-4 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:3-4 }) {Name: DumpRenamedAst.F1}) (HsOuterImplicit [{Name: a} ,{Name: f}]) [(HsTypeArg - { DumpRenamedAst.hs:25:6-11 } - ({ DumpRenamedAst.hs:25:7-11 } + { DumpRenamedAst.hs:25:6 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:7-11 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:25:7-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:7-11 }) {Name: DumpRenamedAst.Peano})))) ,(HsValArg - ({ DumpRenamedAst.hs:25:13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:13 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:25:13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:13 }) {Name: a})))) ,(HsValArg - ({ DumpRenamedAst.hs:25:15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:15 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:25:15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:15 }) {Name: f}))))] (Prefix) - ({ DumpRenamedAst.hs:25:19-30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:19-30 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:25:19-28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:19-28 }) (HsAppTy (NoExtField) - ({ DumpRenamedAst.hs:25:19-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:19-26 }) (HsAppKindTy - { DumpRenamedAst.hs:25:21-26 } - ({ DumpRenamedAst.hs:25:19 } + { DumpRenamedAst.hs:25:21 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:19 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:25:19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:19 }) {Name: DumpRenamedAst.T}))) - ({ DumpRenamedAst.hs:25:22-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:22-26 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:25:22-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:22-26 }) {Name: DumpRenamedAst.Peano}))))) - ({ DumpRenamedAst.hs:25:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:28 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:25:28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:28 }) {Name: f}))))) - ({ DumpRenamedAst.hs:25:30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:30 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:25:30 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:25:30 }) {Name: a})))))))])) - ({ DumpRenamedAst.hs:24:13-14 } + (TopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:13-14 }) {Name: DumpRenamedAst.F1}) (HsQTvs [{Name: k}] - [({ DumpRenamedAst.hs:24:17-22 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:16-23 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:24:16-23 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpRenamedAst.hs:24:19-20 })) + ,(AddApiAnn AnnOpenP (AR { DumpRenamedAst.hs:24:16 })) + ,(AddApiAnn AnnCloseP (AR { DumpRenamedAst.hs:24:23 }))] + (AnnComments + [])) (()) - ({ DumpRenamedAst.hs:24:17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:17 }) {Name: a}) - ({ DumpRenamedAst.hs:24:22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:22 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:24:22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:22 }) {Name: k}))))) - ,({ DumpRenamedAst.hs:24:26-39 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:25-40 }) (KindedTyVar - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:24:25-40 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { DumpRenamedAst.hs:24:28-29 })) + ,(AddApiAnn AnnOpenP (AR { DumpRenamedAst.hs:24:25 })) + ,(AddApiAnn AnnCloseP (AR { DumpRenamedAst.hs:24:40 }))] + (AnnComments + [])) (()) - ({ DumpRenamedAst.hs:24:26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:26 }) {Name: f}) - ({ DumpRenamedAst.hs:24:31-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:31-39 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { DumpRenamedAst.hs:24:31 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { DumpRenamedAst.hs:24:33-34 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ DumpRenamedAst.hs:24:31 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:31 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:24:31 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:31 }) {Name: k}))) - ({ DumpRenamedAst.hs:24:36-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:36-39 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:24:36-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:36-39 }) {Name: GHC.Types.Type})))))))]) (Prefix) - ({ DumpRenamedAst.hs:24:42-48 } + (L + { DumpRenamedAst.hs:24:42-48 } (KindSig (NoExtField) - ({ DumpRenamedAst.hs:24:45-48 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:45-48 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ DumpRenamedAst.hs:24:45-48 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:24:45-48 }) {Name: GHC.Types.Type}))))) (Nothing))))] [] @@ -661,11 +1002,13 @@ [] [] []) - [({ DumpRenamedAst.hs:5:8-21 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:5:8-21 }) (ImportDecl (NoExtField) (NoSourceText) - ({ DumpRenamedAst.hs:5:8-21 } + (L + { DumpRenamedAst.hs:5:8-21 } {ModuleName: Prelude}) (Nothing) (NotBoot) @@ -674,11 +1017,13 @@ (True) (Nothing) (Nothing))) - ,({ DumpRenamedAst.hs:6:1-16 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:6:1-16 }) (ImportDecl (NoExtField) (NoSourceText) - ({ DumpRenamedAst.hs:6:8-16 } + (L + { DumpRenamedAst.hs:6:8-16 } {ModuleName: Data.Kind}) (Nothing) (NotBoot) @@ -687,11 +1032,13 @@ (False) (Nothing) (Nothing))) - ,({ DumpRenamedAst.hs:8:1-23 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:8:1-23 }) (ImportDecl (NoExtField) (NoSourceText) - ({ DumpRenamedAst.hs:8:8-16 } + (L + { DumpRenamedAst.hs:8:8-16 } {ModuleName: Data.Kind}) (Nothing) (NotBoot) @@ -702,15 +1049,30 @@ (Just ((,) (False) - ({ DumpRenamedAst.hs:8:18-23 } - [({ DumpRenamedAst.hs:8:19-22 } + (L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpRenamedAst.hs:8:18-23 } + (UnchangedAnchor)) + (AnnList + (Nothing) + (Just + (AddApiAnn AnnOpenP (AR { DumpRenamedAst.hs:8:18 }))) + (Just + (AddApiAnn AnnCloseP (AR { DumpRenamedAst.hs:8:23 }))) + [] + []) + (AnnComments + [])) { DumpRenamedAst.hs:8:18-23 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:8:19-22 }) (IEThingAbs - (NoExtField) - ({ DumpRenamedAst.hs:8:19-22 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:8:19-22 }) (IEName - ({ DumpRenamedAst.hs:8:19-22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpRenamedAst.hs:8:19-22 }) {Name: GHC.Types.Type})))))])))))] (Nothing) - (Nothing))) - - + (Nothing)))
\ No newline at end of file diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 45488ba165..12471e3f38 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -1,544 +1,1148 @@ ==================== Typechecker AST ==================== -{Bag(Located (HsBind Var)): - [({ <no location info> } +{Bag(LocatedA (HsBind Var)): + [(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: DumpTypecheckedAst.$tcT} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (1374752024144278257) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (13654949607623281177) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: DumpTypecheckedAst.$trModule}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsStringPrim (NoSourceText) "T"))))))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsInt{64}Prim (1) (SourceText "1")})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: DumpTypecheckedAst.$tc'MkT} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (10715337633704422415) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (12411373583424111944) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: DumpTypecheckedAst.$trModule}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsStringPrim (NoSourceText) "'MkT"))))))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsInt{64}Prim (3) (SourceText "3")})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: DumpTypecheckedAst.$tcPeano} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (14073232900889011755) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (2739668351064589274) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: DumpTypecheckedAst.$trModule}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsStringPrim (NoSourceText) "Peano"))))))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsInt{64}Prim (0) (SourceText "0")})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: GHC.Types.krep$*}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: DumpTypecheckedAst.$tc'Zero} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (13760111476013868540) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (12314848029315386153) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: DumpTypecheckedAst.$trModule}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsStringPrim (NoSourceText) "'Zero"))))))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsInt{64}Prim (0) (SourceText "0")})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: DumpTypecheckedAst.$tc'Succ} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (1143980031331647856) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsWord{64}Prim (14802086722010293686) (NoSourceText)})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: DumpTypecheckedAst.$trModule}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsStringPrim (NoSourceText) "'Succ"))))))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) {HsInt{64}Prim (0) (SourceText "0")})))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsInt (NoExtField) (IL - (SourceText - "2") + (SourceText 2) (False) (2))))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsInt (NoExtField) (IL - (SourceText - "1") + (SourceText 1) (False) (1))))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsInt (NoExtField) (IL - (SourceText - "0") + (SourceText 0) (False) (0))))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: GHC.Types.krep$*}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: DumpTypecheckedAst.$tcT}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (XExpr (WrapExpr (HsWrap @@ -549,21 +1153,39 @@ (HsConLikeOut (NoExtField) ({abstract:ConLike})))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (XExpr (WrapExpr (HsWrap @@ -574,21 +1196,39 @@ (HsConLikeOut (NoExtField) ({abstract:ConLike})))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (XExpr (WrapExpr (HsWrap @@ -599,12 +1239,15 @@ (HsConLikeOut (NoExtField) ({abstract:ConLike})))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: $krep}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (XExpr (WrapExpr (HsWrap @@ -615,26 +1258,45 @@ (HsConLikeOut (NoExtField) ({abstract:ConLike})))))))))))))))))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: $krep} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: DumpTypecheckedAst.$tcPeano}))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (XExpr (WrapExpr (HsWrap @@ -645,53 +1307,102 @@ (HsConLikeOut (NoExtField) ({abstract:ConLike})))))))))) - ,({ <no location info> } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (VarBind (NoExtField) {Var: DumpTypecheckedAst.$trModule} - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsStringPrim (NoSourceText) "main"))))))))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsPar - (NoExtField) - ({ <no location info> } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsApp - (NoExtField) - ({ <no location info> } + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsConLikeOut (NoExtField) ({abstract:ConLike}))) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { placeholder:-1:-1 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsStringPrim (NoSourceText) "DumpTypecheckedAst"))))))))))) - ,({ DumpTypecheckedAst.hs:19:1-23 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) (AbsBinds (NoExtField) [] @@ -704,11 +1415,20 @@ (SpecPrags []))] [({abstract:TcEvBinds})] - {Bag(Located (HsBind Var)): - [({ DumpTypecheckedAst.hs:19:1-23 } + {Bag(LocatedA (HsBind Var)): + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { DumpTypecheckedAst.hs:19:1-23 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { DumpTypecheckedAst.hs:19:1-23 }) (FunBind (WpHole) - ({ DumpTypecheckedAst.hs:19:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 }) {Var: main}) (MG (MatchGroupTc @@ -718,42 +1438,52 @@ [(TyConApp ({abstract:TyCon}) [])])) - ({ DumpTypecheckedAst.hs:19:1-23 } - [({ DumpTypecheckedAst.hs:19:1-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) (Match - (NoExtField) + (ApiAnnNotUsed) (FunRhs - ({ DumpTypecheckedAst.hs:19:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 }) {Name: main}) (Prefix) (NoSrcStrict)) [] (GRHSs (NoExtField) - [({ DumpTypecheckedAst.hs:19:6-23 } + [(L + { DumpTypecheckedAst.hs:19:6-23 } (GRHS - (NoExtField) + (ApiAnnNotUsed) [] - ({ DumpTypecheckedAst.hs:19:8-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:8-23 }) (HsApp - (NoExtField) - ({ DumpTypecheckedAst.hs:19:8-15 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:8-15 }) (HsVar (NoExtField) - ({ <no location info> } + (L + (SrcSpanAnn (ApiAnnNotUsed) { <no location info> }) {Var: putStrLn}))) - ({ DumpTypecheckedAst.hs:19:17-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { DumpTypecheckedAst.hs:19:17-23 }) (HsLit - (NoExtField) + (ApiAnn + (Anchor + { DumpTypecheckedAst.hs:19:17-23 } + (UnchangedAnchor)) + (NoApiAnns) + (AnnComments + [])) (HsString - (SourceText - "\"hello\"") + (SourceText "hello") {FastString: "hello"})))))))] - ({ <no location info> } - (EmptyLocalBinds - (NoExtField))))))]) + (EmptyLocalBinds + (NoExtField)))))]) (FromSource)) []))]} - (False)))]} - - + (False)))]}
\ No newline at end of file diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index a8597046e2..12a15b02f1 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -1,19 +1,57 @@ ==================== Parser AST ==================== -({ KindSigs.hs:1:1 } +(L + { KindSigs.hs:1:1 } (HsModule + (ApiAnn + (Anchor + { KindSigs.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddApiAnn AnnModule (AR { KindSigs.hs:6:1-6 })) + ,(AddApiAnn AnnWhere (AR { KindSigs.hs:6:17-21 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { KindSigs.hs:36:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { KindSigs.hs:36:1 }))])) (VirtualBraces (1)) (Just - ({ KindSigs.hs:6:8-15 } + (L + { KindSigs.hs:6:8-15 } {ModuleName: KindSigs})) (Nothing) - [({ KindSigs.hs:8:1-16 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:8:1-16 }) (ImportDecl - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:8:1-6 } + (UnchangedAnchor)) + (ApiAnnImportDecl + (AR { KindSigs.hs:8:1-6 }) + (Nothing) + (Nothing) + (Nothing) + (Nothing) + (Nothing)) + (AnnComments + [])) (NoSourceText) - ({ KindSigs.hs:8:8-16 } + (L + { KindSigs.hs:8:8-16 } {ModuleName: Data.Kind}) (Nothing) (NotBoot) @@ -22,579 +60,1410 @@ (False) (Nothing) (Nothing)))] - [({ KindSigs.hs:11:1-17 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:11:1-17 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:11:1-17 }) (TyClD (NoExtField) (FamDecl (NoExtField) (FamilyDecl - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:11:1-23 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:11:1-4 })) + ,(AddApiAnn AnnFamily (AR { KindSigs.hs:11:6-11 })) + ,(AddApiAnn AnnWhere (AR { KindSigs.hs:11:19-23 }))] + (AnnComments + [])) (ClosedTypeFamily (Just - [({ KindSigs.hs:12:3-21 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:3-21 }) (FamEqn - (NoExtField) - ({ KindSigs.hs:12:3-5 } + (ApiAnn + (Anchor + { KindSigs.hs:12:3-21 } + (UnchangedAnchor)) + [(AddApiAnn AnnEqual (AR { KindSigs.hs:12:9 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:3-5 }) (Unqual {OccName: Foo})) (HsOuterImplicit (NoExtField)) [(HsValArg - ({ KindSigs.hs:12:7 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:7 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:12:7 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:12:7 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:7 }) (Unqual {OccName: a})))))] (Prefix) - ({ KindSigs.hs:12:11-21 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:11-21 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:12:11-13 } + (ApiAnn + (Anchor + { KindSigs.hs:12:11-13 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:12:15-16 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:11-13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:12:11-13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:12:11-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:11-13 }) (Unqual {OccName: Int})))) - ({ KindSigs.hs:12:18-21 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:18-21 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:12:18-21 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:12:18-21 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:12:18-21 }) (Unqual {OccName: Type}))))))))])) - ({ KindSigs.hs:11:13-15 } + (TopLevel) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:11:13-15 }) (Unqual {OccName: Foo})) (HsQTvs (NoExtField) - [({ KindSigs.hs:11:17 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:11:17 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:11:17 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ KindSigs.hs:11:17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:11:17 }) (Unqual {OccName: a}))))]) (Prefix) - ({ <no location info> } + (L + { <no location info> } (NoSig (NoExtField))) (Nothing))))) - ,({ KindSigs.hs:15:1-51 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:15:1-51 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:15:1-51 }) (TyClD (NoExtField) (SynDecl - (NoExtField) - ({ KindSigs.hs:15:6-8 } + (ApiAnn + (Anchor + { KindSigs.hs:15:1-51 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:15:1-4 })) + ,(AddApiAnn AnnEqual (AR { KindSigs.hs:15:12 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:6-8 }) (Unqual {OccName: Bar})) (HsQTvs (NoExtField) - [({ KindSigs.hs:15:10 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:10 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:10 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ KindSigs.hs:15:10 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:10 }) (Unqual {OccName: a}))))]) (Prefix) - ({ KindSigs.hs:15:14-51 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:14-51 }) (HsTupleTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:14 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { KindSigs.hs:15:14 }) + (AR { KindSigs.hs:15:51 })) + (AnnComments + [])) (HsBoxedOrConstraintTuple) - [({ KindSigs.hs:15:16-26 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:15:16-26 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { KindSigs.hs:15:27 }))]) + (AnnComments + [])) { KindSigs.hs:15:16-26 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:15:16-18 } + (ApiAnn + (Anchor + { KindSigs.hs:15:16-18 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:15:20-21 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:16-18 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:16-18 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:15:16-18 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:16-18 }) (Unqual {OccName: Int})))) - ({ KindSigs.hs:15:23-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:23-26 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:23-26 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:15:23-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:23-26 }) (Unqual {OccName: Type})))))) - ,({ KindSigs.hs:15:29-32 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:15:29-32 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { KindSigs.hs:15:33 }))]) + (AnnComments + [])) { KindSigs.hs:15:29-32 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:29-32 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:15:29-32 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:29-32 }) (Unqual {OccName: Bool})))) - ,({ KindSigs.hs:15:35-49 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:35-49 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:15:35-41 } + (ApiAnn + (Anchor + { KindSigs.hs:15:35-41 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:15:43-44 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:35-41 }) (HsAppTy (NoExtField) - ({ KindSigs.hs:15:35-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:35-39 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:35-39 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:15:35-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:35-39 }) (Unqual {OccName: Maybe})))) - ({ KindSigs.hs:15:41 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:41 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:41 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:15:41 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:41 }) (Unqual {OccName: a})))))) - ({ KindSigs.hs:15:46-49 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:46-49 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:15:46-49 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:15:46-49 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:15:46-49 }) (Unqual {OccName: Type}))))))]))))) - ,({ KindSigs.hs:16:1-54 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:16:1-54 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:16:1-54 }) (TyClD (NoExtField) (SynDecl - (NoExtField) - ({ KindSigs.hs:16:6-9 } + (ApiAnn + (Anchor + { KindSigs.hs:16:1-54 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:16:1-4 })) + ,(AddApiAnn AnnEqual (AR { KindSigs.hs:16:13 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:6-9 }) (Unqual {OccName: Bar'})) (HsQTvs (NoExtField) - [({ KindSigs.hs:16:11 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:11 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ KindSigs.hs:16:11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:11 }) (Unqual {OccName: a}))))]) (Prefix) - ({ KindSigs.hs:16:15-54 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:15-54 }) (HsTupleTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:15-16 } + (UnchangedAnchor)) + (AnnParen + (AnnParensHash) + (AR { KindSigs.hs:16:15-16 }) + (AR { KindSigs.hs:16:53-54 })) + (AnnComments + [])) (HsUnboxedTuple) - [({ KindSigs.hs:16:18-28 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:16:18-28 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { KindSigs.hs:16:29 }))]) + (AnnComments + [])) { KindSigs.hs:16:18-28 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:16:18-20 } + (ApiAnn + (Anchor + { KindSigs.hs:16:18-20 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:16:22-23 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:18-20 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:18-20 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:16:18-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:18-20 }) (Unqual {OccName: Int})))) - ({ KindSigs.hs:16:25-28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:25-28 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:25-28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:16:25-28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:25-28 }) (Unqual {OccName: Type})))))) - ,({ KindSigs.hs:16:31-34 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:16:31-34 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { KindSigs.hs:16:35 }))]) + (AnnComments + [])) { KindSigs.hs:16:31-34 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:31-34 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:16:31-34 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:31-34 }) (Unqual {OccName: Bool})))) - ,({ KindSigs.hs:16:37-51 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:37-51 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:16:37-43 } + (ApiAnn + (Anchor + { KindSigs.hs:16:37-43 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:16:45-46 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:37-43 }) (HsAppTy (NoExtField) - ({ KindSigs.hs:16:37-41 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:37-41 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:37-41 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:16:37-41 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:37-41 }) (Unqual {OccName: Maybe})))) - ({ KindSigs.hs:16:43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:43 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:43 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:16:43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:43 }) (Unqual {OccName: a})))))) - ({ KindSigs.hs:16:48-51 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:48-51 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:16:48-51 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:16:48-51 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:16:48-51 }) (Unqual {OccName: Type}))))))]))))) - ,({ KindSigs.hs:19:1-26 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:19:1-26 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:19:1-26 }) (TyClD (NoExtField) (SynDecl - (NoExtField) - ({ KindSigs.hs:19:6-8 } + (ApiAnn + (Anchor + { KindSigs.hs:19:1-26 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:19:1-4 })) + ,(AddApiAnn AnnEqual (AR { KindSigs.hs:19:10 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:19:6-8 }) (Unqual {OccName: Baz})) (HsQTvs (NoExtField) []) (Prefix) - ({ KindSigs.hs:19:12-26 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:19:12-26 }) (HsListTy - (NoExtField) - ({ KindSigs.hs:19:14-24 } + (ApiAnn + (Anchor + { KindSigs.hs:19:12 } + (UnchangedAnchor)) + (AnnParen + (AnnParensSquare) + (AR { KindSigs.hs:19:12 }) + (AR { KindSigs.hs:19:26 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:19:14-24 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:19:14-16 } + (ApiAnn + (Anchor + { KindSigs.hs:19:14-16 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:19:18-19 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:19:14-16 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:19:14-16 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:19:14-16 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:19:14-16 }) (Unqual {OccName: Int})))) - ({ KindSigs.hs:19:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:19:21-24 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:19:21-24 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:19:21-24 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:19:21-24 }) (Unqual {OccName: Type}))))))))))) - ,({ KindSigs.hs:22:1-44 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:22:1-44 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:22:1-44 }) (SigD (NoExtField) (TypeSig - (NoExtField) - [({ KindSigs.hs:22:1-3 } + (ApiAnn + (Anchor + { KindSigs.hs:22:1-3 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { KindSigs.hs:22:5-6 })) + []) + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:1-3 }) (Unqual {OccName: qux}))] (HsWC (NoExtField) - ({ KindSigs.hs:22:8-44 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:8-44 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ KindSigs.hs:22:8-44 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:8-44 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:22:8-20 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { KindSigs.hs:22:22-23 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ KindSigs.hs:22:8-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:8-20 }) (HsParTy - (NoExtField) - ({ KindSigs.hs:22:9-19 } + (ApiAnn + (Anchor + { KindSigs.hs:22:8 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { KindSigs.hs:22:8 }) + (AR { KindSigs.hs:22:20 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:9-19 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:22:9-11 } + (ApiAnn + (Anchor + { KindSigs.hs:22:9-11 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:22:13-14 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:9-11 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:22:9-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:22:9-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:9-11 }) (Unqual {OccName: Int})))) - ({ KindSigs.hs:22:16-19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:16-19 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:22:16-19 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:22:16-19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:16-19 }) (Unqual {OccName: Type})))))))) - ({ KindSigs.hs:22:25-44 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:25-44 }) (HsFunTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:22:25-28 } + (UnchangedAnchor)) + (AddRarrowAnn + (AR { KindSigs.hs:22:30-31 })) + (AnnComments + [])) (HsUnrestrictedArrow (NormalSyntax)) - ({ KindSigs.hs:22:25-28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:25-28 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:22:25-28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:22:25-28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:25-28 }) (Unqual {OccName: Bool})))) - ({ KindSigs.hs:22:33-44 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:33-44 }) (HsParTy - (NoExtField) - ({ KindSigs.hs:22:34-43 } + (ApiAnn + (Anchor + { KindSigs.hs:22:33 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { KindSigs.hs:22:33 }) + (AR { KindSigs.hs:22:44 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:34-43 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:22:34-35 } + (ApiAnn + (Anchor + { KindSigs.hs:22:34-35 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:22:37-38 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:34-35 }) (HsTupleTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:22:34 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { KindSigs.hs:22:34 }) + (AR { KindSigs.hs:22:35 })) + (AnnComments + [])) (HsBoxedOrConstraintTuple) [])) - ({ KindSigs.hs:22:40-43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:40-43 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:22:40-43 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:22:40-43 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:22:40-43 }) (Unqual {OccName: Type})))))))))))))))))) - ,({ KindSigs.hs:23:1-12 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:23:1-12 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:23:1-12 }) (ValD (NoExtField) (FunBind (NoExtField) - ({ KindSigs.hs:23:1-3 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:23:1-3 }) (Unqual {OccName: qux})) (MG (NoExtField) - ({ KindSigs.hs:23:1-12 } - [({ KindSigs.hs:23:1-12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:23:1-12 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:23:1-12 }) (Match - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:23:1-12 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (FunRhs - ({ KindSigs.hs:23:1-3 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:23:1-3 }) (Unqual {OccName: qux})) (Prefix) (NoSrcStrict)) - [({ KindSigs.hs:23:5 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:23:5 }) (WildPat (NoExtField))) - ,({ KindSigs.hs:23:7 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:23:7 }) (WildPat (NoExtField)))] (GRHSs (NoExtField) - [({ KindSigs.hs:23:9-12 } + [(L + { KindSigs.hs:23:9-12 } (GRHS - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:23:9-12 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddApiAnn AnnEqual (AR { KindSigs.hs:23:9 }))) + (AnnComments + [])) [] - ({ KindSigs.hs:23:11-12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:23:11-12 }) (HsVar (NoExtField) - ({ KindSigs.hs:23:11-12 } + (L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:23:11-12 } + (UnchangedAnchor)) + (NameAnnOnly + (NameParens) + (AR { KindSigs.hs:23:11 }) + (AR { KindSigs.hs:23:12 }) + []) + (AnnComments + [])) { KindSigs.hs:23:11-12 }) (Exact {Name: ()}))))))] - ({ <no location info> } - (EmptyLocalBinds - (NoExtField))))))]) + (EmptyLocalBinds + (NoExtField)))))]) (FromSource)) []))) - ,({ KindSigs.hs:26:1-29 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:26:1-29 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:26:1-29 }) (TyClD (NoExtField) (SynDecl - (NoExtField) - ({ KindSigs.hs:26:6-9 } + (ApiAnn + (Anchor + { KindSigs.hs:26:1-29 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:26:1-4 })) + ,(AddApiAnn AnnEqual (AR { KindSigs.hs:26:11 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:26:6-9 }) (Unqual {OccName: Quux})) (HsQTvs (NoExtField) []) (Prefix) - ({ KindSigs.hs:26:13-29 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:26:13-29 }) (HsExplicitListTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:26:13 } + (UnchangedAnchor)) + [(AddApiAnn AnnSimpleQuote (AR { KindSigs.hs:26:13 })) + ,(AddApiAnn AnnOpenS (AR { KindSigs.hs:26:14 })) + ,(AddApiAnn AnnCloseS (AR { KindSigs.hs:26:29 }))] + (AnnComments + [])) (IsPromoted) - [({ KindSigs.hs:26:16-27 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:26:16-27 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:26:16-19 } + (ApiAnn + (Anchor + { KindSigs.hs:26:16-19 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:26:21-22 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:26:16-19 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:26:16-19 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:26:16-19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:26:16-19 }) (Unqual {OccName: True})))) - ({ KindSigs.hs:26:24-27 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:26:24-27 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:26:24-27 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:26:24-27 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:26:24-27 }) (Unqual {OccName: Bool}))))))]))))) - ,({ KindSigs.hs:27:1-45 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:27:1-45 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:27:1-45 }) (TyClD (NoExtField) (SynDecl - (NoExtField) - ({ KindSigs.hs:27:6-10 } + (ApiAnn + (Anchor + { KindSigs.hs:27:1-45 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:27:1-4 })) + ,(AddApiAnn AnnEqual (AR { KindSigs.hs:27:12 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:6-10 }) (Unqual {OccName: Quux'})) (HsQTvs (NoExtField) []) (Prefix) - ({ KindSigs.hs:27:14-45 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:14-45 }) (HsExplicitListTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:27:14 } + (UnchangedAnchor)) + [(AddApiAnn AnnOpenS (AR { KindSigs.hs:27:14 })) + ,(AddApiAnn AnnCloseS (AR { KindSigs.hs:27:45 }))] + (AnnComments + [])) (NotPromoted) - [({ KindSigs.hs:27:16-27 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:27:16-27 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { KindSigs.hs:27:28 }))]) + (AnnComments + [])) { KindSigs.hs:27:16-27 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:27:16-19 } + (ApiAnn + (Anchor + { KindSigs.hs:27:16-19 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:27:21-22 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:16-19 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:27:16-19 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:27:16-19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:16-19 }) (Unqual {OccName: True})))) - ({ KindSigs.hs:27:24-27 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:24-27 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:27:24-27 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:27:24-27 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:24-27 }) (Unqual {OccName: Bool})))))) - ,({ KindSigs.hs:27:30-42 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:30-42 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:27:30-34 } + (ApiAnn + (Anchor + { KindSigs.hs:27:30-34 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:27:36-37 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:30-34 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:27:30-34 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:27:30-34 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:30-34 }) (Unqual {OccName: False})))) - ({ KindSigs.hs:27:39-42 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:39-42 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:27:39-42 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:27:39-42 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:27:39-42 }) (Unqual {OccName: Bool}))))))]))))) - ,({ KindSigs.hs:28:1-44 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:28:1-44 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:28:1-44 }) (TyClD (NoExtField) (SynDecl - (NoExtField) - ({ KindSigs.hs:28:6-10 } + (ApiAnn + (Anchor + { KindSigs.hs:28:1-44 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:28:1-4 })) + ,(AddApiAnn AnnEqual (AR { KindSigs.hs:28:14 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:6-10 }) (Unqual {OccName: Quuux})) (HsQTvs (NoExtField) - [({ KindSigs.hs:28:12 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:12 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:28:12 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ KindSigs.hs:28:12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:12 }) (Unqual {OccName: b}))))]) (Prefix) - ({ KindSigs.hs:28:16-44 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:16-44 }) (HsExplicitTupleTy - (NoExtField) - [({ KindSigs.hs:28:19-39 } + (ApiAnn + (Anchor + { KindSigs.hs:28:16 } + (UnchangedAnchor)) + [(AddApiAnn AnnSimpleQuote (AR { KindSigs.hs:28:16 })) + ,(AddApiAnn AnnOpenP (AR { KindSigs.hs:28:17 })) + ,(AddApiAnn AnnCloseP (AR { KindSigs.hs:28:44 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:28:19-39 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { KindSigs.hs:28:40 }))]) + (AnnComments + [])) { KindSigs.hs:28:19-39 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:28:19-29 } + (ApiAnn + (Anchor + { KindSigs.hs:28:19-29 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:28:31-32 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:19-29 }) (HsExplicitListTy - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:28:19 } + (UnchangedAnchor)) + [(AddApiAnn AnnOpenS (AR { KindSigs.hs:28:19 })) + ,(AddApiAnn AnnCloseS (AR { KindSigs.hs:28:29 }))] + (AnnComments + [])) (NotPromoted) - [({ KindSigs.hs:28:20-22 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:28:20-22 } + (UnchangedAnchor)) + (AnnListItem + [(AddCommaAnn + (AR { KindSigs.hs:28:23 }))]) + (AnnComments + [])) { KindSigs.hs:28:20-22 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:28:20-22 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:28:20-22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:20-22 }) (Unqual {OccName: Int})))) - ,({ KindSigs.hs:28:25-28 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:25-28 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:28:25-28 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:28:25-28 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:25-28 }) (Unqual {OccName: Bool}))))])) - ({ KindSigs.hs:28:34-39 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:34-39 }) (HsListTy - (NoExtField) - ({ KindSigs.hs:28:35-38 } + (ApiAnn + (Anchor + { KindSigs.hs:28:34 } + (UnchangedAnchor)) + (AnnParen + (AnnParensSquare) + (AR { KindSigs.hs:28:34 }) + (AR { KindSigs.hs:28:39 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:35-38 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:28:35-38 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:28:35-38 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:35-38 }) (Unqual {OccName: Type})))))))) - ,({ KindSigs.hs:28:42 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:42 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:28:42 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:28:42 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:28:42 }) (Unqual {OccName: b}))))]))))) - ,({ KindSigs.hs:31:1-31 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:31:1-31 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:31:1-31 }) (TyClD (NoExtField) (SynDecl - (NoExtField) - ({ KindSigs.hs:31:6-17 } + (ApiAnn + (Anchor + { KindSigs.hs:31:1-31 } + (UnchangedAnchor)) + [(AddApiAnn AnnType (AR { KindSigs.hs:31:1-4 })) + ,(AddApiAnn AnnEqual (AR { KindSigs.hs:31:19 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:31:6-17 }) (Unqual {OccName: Sarsaparilla})) (HsQTvs (NoExtField) []) (Prefix) - ({ KindSigs.hs:31:21-31 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:31:21-31 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:31:21-23 } + (ApiAnn + (Anchor + { KindSigs.hs:31:21-23 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:31:25-26 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:31:21-23 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:31:21-23 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:31:21-23 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:31:21-23 }) (Unqual {OccName: Int})))) - ({ KindSigs.hs:31:28-31 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:31:28-31 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:31:28-31 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:31:28-31 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:31:28-31 }) (Unqual {OccName: Type}))))))))) - ,({ KindSigs.hs:34:1-22 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:34:1-22 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:34:1-22 }) (SigD (NoExtField) (TypeSig - (NoExtField) - [({ KindSigs.hs:34:1-4 } + (ApiAnn + (Anchor + { KindSigs.hs:34:1-4 } + (UnchangedAnchor)) + (AnnSig + (AddApiAnn AnnDcolon (AR { KindSigs.hs:34:6-7 })) + []) + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:1-4 }) (Unqual {OccName: true}))] (HsWC (NoExtField) - ({ KindSigs.hs:34:9-22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:9-22 }) (HsSig (NoExtField) (HsOuterImplicit (NoExtField)) - ({ KindSigs.hs:34:9-22 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:9-22 }) (HsParTy - (NoExtField) - ({ KindSigs.hs:34:10-21 } + (ApiAnn + (Anchor + { KindSigs.hs:34:9 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { KindSigs.hs:34:9 }) + (AR { KindSigs.hs:34:22 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:10-21 }) (HsKindSig - (NoExtField) - ({ KindSigs.hs:34:10-13 } + (ApiAnn + (Anchor + { KindSigs.hs:34:10-13 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { KindSigs.hs:34:15-16 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:10-13 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:34:10-13 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:34:10-13 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:10-13 }) (Unqual {OccName: Bool})))) - ({ KindSigs.hs:34:18-21 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:18-21 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:34:18-21 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ KindSigs.hs:34:18-21 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:34:18-21 }) (Unqual {OccName: Type})))))))))))))) - ,({ KindSigs.hs:35:1-11 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { KindSigs.hs:35:1-11 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { KindSigs.hs:35:1-11 }) (ValD (NoExtField) (FunBind (NoExtField) - ({ KindSigs.hs:35:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:35:1-4 }) (Unqual {OccName: true})) (MG (NoExtField) - ({ KindSigs.hs:35:1-11 } - [({ KindSigs.hs:35:1-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:35:1-11 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:35:1-11 }) (Match - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:35:1-11 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (FunRhs - ({ KindSigs.hs:35:1-4 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:35:1-4 }) (Unqual {OccName: true})) (Prefix) @@ -602,22 +1471,30 @@ [] (GRHSs (NoExtField) - [({ KindSigs.hs:35:6-11 } + [(L + { KindSigs.hs:35:6-11 } (GRHS - (NoExtField) + (ApiAnn + (Anchor + { KindSigs.hs:35:6-11 } + (UnchangedAnchor)) + (GrhsAnn + (Nothing) + (AddApiAnn AnnEqual (AR { KindSigs.hs:35:6 }))) + (AnnComments + [])) [] - ({ KindSigs.hs:35:8-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:35:8-11 }) (HsVar (NoExtField) - ({ KindSigs.hs:35:8-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { KindSigs.hs:35:8-11 }) (Unqual {OccName: True}))))))] - ({ <no location info> } - (EmptyLocalBinds - (NoExtField))))))]) + (EmptyLocalBinds + (NoExtField)))))]) (FromSource)) [])))] (Nothing) (Nothing))) - - diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 516850592c..d76f449c03 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -12,88 +12,140 @@ [] [(TyClGroup (NoExtField) - [({ T14189.hs:6:1-42 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { T14189.hs:6:1-42 } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T14189.hs:6:1-42 }) (DataDecl (DataDeclRn (True) {NameSet: [{Name: GHC.Types.Int}]}) - ({ T14189.hs:6:6-11 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:6-11 }) {Name: T14189.MyType}) (HsQTvs [] []) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnnNotUsed) (DataType) (Nothing) (Nothing) (Nothing) - [({ T14189.hs:6:15-20 } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { T14189.hs:6:15-20 } + (UnchangedAnchor)) + (AnnListItem + [(AddVbarAnn + (AR { T14189.hs:6:22 }))]) + (AnnComments + [])) { T14189.hs:6:15-20 }) (ConDeclH98 - (NoExtField) - ({ T14189.hs:6:15-16 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:15-16 }) {Name: T14189.MT}) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] [(HsScaled (HsLinearArrow - (NormalSyntax)) - ({ T14189.hs:6:18-20 } + (NormalSyntax) + (Nothing)) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:18-20 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ T14189.hs:6:18-20 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:18-20 }) {Name: GHC.Types.Int}))))]) (Nothing))) - ,({ T14189.hs:6:24-25 } + ,(L + (SrcSpanAnn (ApiAnn + (Anchor + { T14189.hs:6:24-25 } + (UnchangedAnchor)) + (AnnListItem + [(AddVbarAnn + (AR { T14189.hs:6:27 }))]) + (AnnComments + [])) { T14189.hs:6:24-25 }) (ConDeclH98 - (NoExtField) - ({ T14189.hs:6:24-25 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:24-25 }) {Name: T14189.NT}) - ({ <no location info> } - (False)) + (False) [] (Nothing) (PrefixCon [] []) (Nothing))) - ,({ T14189.hs:6:29-42 } + ,(L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:29-42 }) (ConDeclH98 - (NoExtField) - ({ T14189.hs:6:29 } + (ApiAnnNotUsed) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:29 }) {Name: T14189.F}) - ({ <no location info> } - (False)) + (False) [] (Nothing) (RecCon - ({ T14189.hs:6:31-42 } - [({ T14189.hs:6:33-40 } + (L + (SrcSpanAnn (ApiAnn + (Anchor + { T14189.hs:6:31 } + (UnchangedAnchor)) + (AnnList + (Just + (Anchor + { T14189.hs:6:33-40 } + (UnchangedAnchor))) + (Just + (AddApiAnn AnnOpenC (AR { T14189.hs:6:31 }))) + (Just + (AddApiAnn AnnCloseC (AR { T14189.hs:6:42 }))) + [] + []) + (AnnComments + [])) { T14189.hs:6:31-42 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:33-40 }) (ConDeclField - (NoExtField) - [({ T14189.hs:6:33 } + (ApiAnnNotUsed) + [(L + { T14189.hs:6:33 } (FieldOcc {Name: T14189.f} - ({ T14189.hs:6:33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:33 }) (Unqual {OccName: f}))))] - ({ T14189.hs:6:38-40 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:38-40 }) (HsTyVar - (NoExtField) + (ApiAnnNotUsed) (NotPromoted) - ({ T14189.hs:6:38-40 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:6:38-40 }) {Name: GHC.Types.Int}))) (Nothing)))])) (Nothing)))] - ({ <no location info> } - []))))] + [])))] [] [] [])] @@ -105,11 +157,13 @@ [] [] []) - [({ T14189.hs:1:8-13 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:1:8-13 }) (ImportDecl (NoExtField) (NoSourceText) - ({ T14189.hs:1:8-13 } + (L + { T14189.hs:1:8-13 } {ModuleName: Prelude}) (Nothing) (NotBoot) @@ -120,22 +174,28 @@ (Nothing)))] (Just [((,) - ({ T14189.hs:3:3-15 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:3:3-15 }) (IEThingWith - [({ T14189.hs:3:11 } + [(L + { T14189.hs:3:11 } (FieldLabel {FastString: "f"} (NoDuplicateRecordFields) (FieldSelectors) {Name: T14189.f}))] - ({ T14189.hs:3:3-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:3:3-8 }) (IEName - ({ T14189.hs:3:3-8 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:3:3-8 }) {Name: T14189.MyType}))) (NoIEWildcard) - [({ T14189.hs:3:13-14 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:3:13-14 }) (IEName - ({ T14189.hs:3:13-14 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T14189.hs:3:13-14 }) {Name: T14189.NT})))])) [(AvailTC {Name: T14189.MyType} @@ -150,5 +210,3 @@ (FieldSelectors) {Name: T14189.f}))])])]) (Nothing))) - - diff --git a/testsuite/tests/parser/should_compile/T15279.stderr b/testsuite/tests/parser/should_compile/T15279.stderr index ff215a763d..b8a1580c76 100644 --- a/testsuite/tests/parser/should_compile/T15279.stderr +++ b/testsuite/tests/parser/should_compile/T15279.stderr @@ -1,3 +1,4 @@ (MG -(NoExt) -({ <combineSrcSpans: files differ> } +(NoExtField) +(L +(SrcSpanAnn (ApiAnnNotUsed) { <combineSrcSpans: files differ> }) diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr index 91f85727f6..1c7fdc68c6 100644 --- a/testsuite/tests/parser/should_compile/T15323.stderr +++ b/testsuite/tests/parser/should_compile/T15323.stderr @@ -1,100 +1,234 @@ ==================== Parser AST ==================== -({ T15323.hs:1:1 } +(L + { T15323.hs:1:1 } (HsModule + (ApiAnn + (Anchor + { T15323.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddApiAnn AnnModule (AR { T15323.hs:3:1-6 })) + ,(AddApiAnn AnnWhere (AR { T15323.hs:3:15-19 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { T15323.hs:7:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { T15323.hs:7:1 }))])) (VirtualBraces (1)) (Just - ({ T15323.hs:3:8-13 } + (L + { T15323.hs:3:8-13 } {ModuleName: T15323})) (Nothing) [] - [({ T15323.hs:(5,1)-(6,54) } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { T15323.hs:(5,1)-(6,54) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T15323.hs:(5,1)-(6,54) }) (TyClD (NoExtField) (DataDecl - (NoExtField) - ({ T15323.hs:5:6-17 } + (ApiAnn + (Anchor + { T15323.hs:(5,1)-(6,54) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T15323.hs:5:1-4 })) + ,(AddApiAnn AnnWhere (AR { T15323.hs:5:21-25 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:5:6-17 }) (Unqual {OccName: MaybeDefault})) (HsQTvs (NoExtField) - [({ T15323.hs:5:19 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:5:19 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T15323.hs:5:19 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (()) - ({ T15323.hs:5:19 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:5:19 }) (Unqual {OccName: v}))))]) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T15323.hs:(5,1)-(6,54) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T15323.hs:5:1-4 })) + ,(AddApiAnn AnnWhere (AR { T15323.hs:5:21-25 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T15323.hs:6:5-54 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:5-54 }) (ConDeclGADT - (NoExtField) - [({ T15323.hs:6:5-14 } + (ApiAnn + (Anchor + { T15323.hs:6:5-54 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T15323.hs:6:17-18 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:5-14 }) (Unqual {OccName: TestParens}))] - ({ T15323.hs:6:20-54 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:20-54 }) (HsOuterExplicit - (NoExtField) - [({ T15323.hs:6:27 } + (ApiAnn + (Anchor + { T15323.hs:6:20-25 } + (UnchangedAnchor)) + ((,) + (AddApiAnn AnnForall (AR { T15323.hs:6:20-25 })) + (AddApiAnn AnnDot (AR { T15323.hs:6:29 }))) + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:27 }) (UserTyVar - (NoExtField) + (ApiAnn + (Anchor + { T15323.hs:6:27 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (SpecifiedSpec) - ({ T15323.hs:6:27 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:27 }) (Unqual {OccName: v}))))])) (Just - ({ T15323.hs:6:31-36 } - [({ T15323.hs:6:31-36 } + (L + (SrcSpanAnn (ApiAnn + (Anchor + { T15323.hs:6:31-36 } + (UnchangedAnchor)) + (AnnContext + (Just + ((,) + (NormalSyntax) + (AR { T15323.hs:6:38-39 }))) + [] + []) + (AnnComments + [])) { T15323.hs:6:31-36 }) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:31-36 }) (HsParTy - (NoExtField) - ({ T15323.hs:6:32-35 } + (ApiAnn + (Anchor + { T15323.hs:6:31 } + (UnchangedAnchor)) + (AnnParen + (AnnParens) + (AR { T15323.hs:6:31 }) + (AR { T15323.hs:6:36 })) + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:32-35 }) (HsAppTy (NoExtField) - ({ T15323.hs:6:32-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:32-33 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T15323.hs:6:32-33 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T15323.hs:6:32-33 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:32-33 }) (Unqual {OccName: Eq})))) - ({ T15323.hs:6:35 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:35 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T15323.hs:6:35 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T15323.hs:6:35 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:35 }) (Unqual {OccName: v}))))))))])) (PrefixConGADT []) - ({ T15323.hs:6:41-54 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:41-54 }) (HsAppTy (NoExtField) - ({ T15323.hs:6:41-52 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:41-52 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T15323.hs:6:41-52 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T15323.hs:6:41-52 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:41-52 }) (Unqual {OccName: MaybeDefault})))) - ({ T15323.hs:6:54 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:54 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T15323.hs:6:54 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T15323.hs:6:54 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T15323.hs:6:54 }) (Unqual {OccName: v})))))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing) (Nothing))) - - diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index d2b3a69385..64c0138ca1 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -132,11 +132,12 @@ def only_MG_loc(x): """ Only compares the location embedded inside the MatchGroup, which has the form (MG - (NoExt) - ({ <location> + (NoExtField) + (L + (SrcSpanAnn (ApiAnnNotUsed) { <location> }) """ ls = x.split("\n") - mgLocs = (loc.strip() for (mg,loc) in zip(ls,ls[2:]) + mgLocs = (loc.strip() for (mg,loc) in zip(ls,ls[3:]) if mg.strip().startswith("(MG")) return '\n'.join(mgLocs) test('T15279', normalise_errmsg_fun(only_MG_loc), compile, ['']) diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr index 4ca1005185..2378585a6a 100644 --- a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr @@ -10,16 +10,16 @@ RecordDotSyntaxFail11.hs:8:3: ...plus N instances involving out-of-scope types (use -fprint-potential-instances to see them all) In the first argument of ‘($)’, namely ‘print’ - In a stmt of a 'do' block: print $ (foo.bar.baz) a + In a stmt of a 'do' block: print $ (.foo.bar.baz) a In the expression: do let a = ... - print $ (foo.bar.baz) a + print $ (.foo.bar.baz) a RecordDotSyntaxFail11.hs:8:11: No instance for (GHC.Records.HasField "baz" Int a0) arising from a use of ‘GHC.Records.getField’ - In the second argument of ‘($)’, namely ‘(foo.bar.baz) a’ - In a stmt of a 'do' block: print $ (foo.bar.baz) a + In the second argument of ‘($)’, namely ‘(.foo.bar.baz) a’ + In a stmt of a 'do' block: print $ (.foo.bar.baz) a In the expression: do let a = ... - print $ (foo.bar.baz) a + print $ (.foo.bar.baz) a diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs index 33c1ab78be..adfa6e28cf 100644 --- a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs +++ b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs @@ -9,6 +9,7 @@ import GHC.Hs.Extension import GHC.Hs.Lit import GHC.Driver.Hooks import GHC.Tc.Utils.Monad +import GHC.Parser.Annotation plugin :: Plugin plugin = defaultPlugin { driverPlugin = hooksP } @@ -30,7 +31,7 @@ fakeRunMeta opts (MetaE r) _ = do pure $ r zero where zero :: LHsExpr GhcPs - zero = L noSrcSpan $ HsLit NoExtField $ + zero = noLocA $ HsLit noAnn $ HsInt NoExtField (mkIntegralLit (0 :: Int)) fakeRunMeta _ _ _ = error "fakeRunMeta: unimplemented" diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 1be722ed0d..26353ce507 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -60,7 +60,7 @@ metaPlugin' [name, "meta"] (L l (HsPar x (L _ (XExpr (WrapExpr (HsWrap w (HsApp -- The test should always match this first case. If the desugaring changes -- again in the future then the panic is more useful than the previous -- inscrutable failure. -metaPlugin' _ meta = pprPanic "meta" (showAstData BlankSrcSpan meta) +metaPlugin' _ meta = pprPanic "meta" (showAstData BlankSrcSpan BlankApiAnnotations meta) interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface interfaceLoadPlugin' [name, "interface"] iface diff --git a/testsuite/tests/polykinds/T9144.stderr b/testsuite/tests/polykinds/T9144.stderr index dc3e13ed11..6d5c3c0b44 100644 --- a/testsuite/tests/polykinds/T9144.stderr +++ b/testsuite/tests/polykinds/T9144.stderr @@ -6,4 +6,4 @@ T9144.hs:34:26: error: • In the first argument of ‘toSing’, namely ‘n’ In the expression: toSing n In the expression: - case toSing n of { SomeSing n' -> SomeSing (SBar n') } + case toSing n of SomeSing n' -> SomeSing (SBar n') diff --git a/testsuite/tests/ghc-api/annotations/AnnotationLet.hs b/testsuite/tests/printer/AnnotationLet.hs index ad67b927f4..ad67b927f4 100644 --- a/testsuite/tests/ghc-api/annotations/AnnotationLet.hs +++ b/testsuite/tests/printer/AnnotationLet.hs diff --git a/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs b/testsuite/tests/printer/AnnotationTuple.hs index 73015a6bc5..73015a6bc5 100644 --- a/testsuite/tests/ghc-api/annotations/AnnotationTuple.hs +++ b/testsuite/tests/printer/AnnotationTuple.hs diff --git a/testsuite/tests/ghc-api/annotations/BundleExport.hs b/testsuite/tests/printer/BundleExport.hs index 31d00601a8..31d00601a8 100644 --- a/testsuite/tests/ghc-api/annotations/BundleExport.hs +++ b/testsuite/tests/printer/BundleExport.hs diff --git a/testsuite/tests/ghc-api/annotations/ListComprehensions.hs b/testsuite/tests/printer/ListComprehensions.hs index 0738da5173..0738da5173 100644 --- a/testsuite/tests/ghc-api/annotations/ListComprehensions.hs +++ b/testsuite/tests/printer/ListComprehensions.hs diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index f1199f3acf..2f3d7fb187 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -8,228 +8,540 @@ clean: .PHONY: ppr001 ppr001: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr001.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr001.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr001.hs .PHONY: ppr002 ppr002: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr002.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr002.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr002.hs + +.PHONY: ppr002a +ppr002a: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr002a.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr002a.hs .PHONY: ppr003 ppr003: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr003.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr003.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr003.hs .PHONY: ppr004 ppr004: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr004.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr004.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr004.hs .PHONY: ppr005 ppr005: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr005.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr005.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr005.hs .PHONY: ppr006 ppr006: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr006.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr006.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr006.hs .PHONY: ppr007 ppr007: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr007.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr007.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr007.hs .PHONY: ppr008 ppr008: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr008.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr008.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr008.hs .PHONY: ppr009 ppr009: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr009.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr009.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr009.hs .PHONY: ppr010 ppr010: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr010.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr010.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr010.hs .PHONY: ppr011 ppr011: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr011.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr011.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr011.hs .PHONY: ppr012 ppr012: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr012.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr012.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr012.hs .PHONY: ppr013 ppr013: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr013.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr013.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr013.hs .PHONY: ppr014 ppr014: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr014.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr014.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr014.hs .PHONY: ppr015 ppr015: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr015.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr015.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr015.hs .PHONY: ppr016 ppr016: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr016.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr016.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr016.hs .PHONY: ppr017 ppr017: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr017.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr017.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr017.hs .PHONY: ppr018 ppr018: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr018.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr018.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr018.hs .PHONY: ppr019 ppr019: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr019.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr019.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr019.hs .PHONY: ppr020 ppr020: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr020.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr020.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr020.hs .PHONY: ppr021 ppr021: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr021.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr021.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr021.hs .PHONY: ppr022 ppr022: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr022.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr022.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr022.hs .PHONY: ppr023 ppr023: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr023.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr023.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr023.hs .PHONY: ppr024 ppr024: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr024.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr024.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr024.hs .PHONY: ppr025 ppr025: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr025.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr025.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr025.hs .PHONY: ppr026 ppr026: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr026.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr026.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr026.hs .PHONY: ppr027 ppr027: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr027.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr027.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr027.hs .PHONY: ppr028 ppr028: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr028.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr028.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr028.hs .PHONY: ppr029 ppr029: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr029.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr029.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr029.hs .PHONY: ppr030 ppr030: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr030.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr030.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr030.hs .PHONY: ppr031 ppr031: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr031.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr031.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr031.hs .PHONY: ppr032 ppr032: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr032.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr032.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr032.hs .PHONY: ppr033 ppr033: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr033.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr033.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr033.hs .PHONY: ppr034 ppr034: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr034.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr034.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr034.hs .PHONY: ppr035 ppr035: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr035.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr035.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr035.hs .PHONY: ppr036 ppr036: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr036.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr036.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr036.hs .PHONY: ppr037 ppr037: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr037.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr037.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr037.hs .PHONY: ppr038 ppr038: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr038.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr038.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr038.hs .PHONY: ppr039 ppr039: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr039.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr039.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr039.hs .PHONY: ppr040 ppr040: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr040.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr040.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr040.hs .PHONY: ppr041 ppr041: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr041.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr041.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr041.hs .PHONY: ppr042 ppr042: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr042.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr042.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr042.hs .PHONY: ppr043 ppr043: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr043.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr043.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr043.hs .PHONY: ppr044 ppr044: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr044.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr044.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr044.hs .PHONY: ppr045 ppr045: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr045.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr045.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr045.hs .PHONY: ppr046 ppr046: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr046.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr046.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr046.hs .PHONY: ppr048 ppr048: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr048.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr048.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr048.hs + +.PHONY: ppr049 +ppr049: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr049.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr049.hs + +.PHONY: ppr050 +ppr050: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr050.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr050.hs + +.PHONY: ppr051 +ppr051: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr051.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr051.hs + +.PHONY: ppr052 +ppr052: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr052.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr052.hs + +.PHONY: ppr053 +ppr053: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr053.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr053.hs + +.PHONY: ppr054 +ppr054: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr054.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr054.hs + +.PHONY: ppr055 +ppr055: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr055.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr055.hs .PHONY: T13199 T13199: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13199.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13199.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13199.hs .PHONY: T13050p T13050p: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13050p.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13050p.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13050p.hs .PHONY: T13550 T13550: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13550.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13550.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13550.hs .PHONY: T13942 T13942: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13942.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13942.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13942.hs .PHONY: T14289 T14289: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289.hs .PHONY: T14289b T14289b: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289b.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289b.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289b.hs .PHONY: T14289c T14289c: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289c.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289c.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289c.hs .PHONY: T14306 T14306: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs .PHONY: T14343 T14343: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343.hs .PHONY: T14343b T14343b: - $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343b.hs + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343b.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343b.hs + +.PHONY: RdrNames +RdrNames: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" RdrNames.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" RdrNames.hs + +.PHONY: StarBinderAnns +StarBinderAnns: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" StarBinderAnns.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" StarBinderAnns.hs + +.PHONY: Test10255 +Test10255: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10255.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10255.hs + +.PHONY: Test10268 +Test10268: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10268.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10268.hs + +.PHONY: Test10269 +Test10269: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10269.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10269.hs + +.PHONY: Test10276 +Test10276: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10276.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10276.hs + +.PHONY: Test10278 +Test10278: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10278.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10278.hs + +.PHONY: Test10280 +Test10280: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10280.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10280.hs + +.PHONY: Test10307 +Test10307: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10307.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10307.hs + +.PHONY: Test10309 +Test10309: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10309.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10309.hs + +.PHONY: Test10312 +Test10312: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10312.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10312.hs + +.PHONY: Test10313 +Test10313: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10313.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10313.hs + +.PHONY: Test10354 +Test10354: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10354.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10354.hs + +.PHONY: Test10357 +Test10357: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10357.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10357.hs + +.PHONY: Test10358 +Test10358: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10358.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10358.hs + +.PHONY: Test10396 +Test10396: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10396.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10396.hs + +.PHONY: Test10399 +Test10399: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10399.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10399.hs + +.PHONY: Test10598 +Test10598: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10598.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10598.hs + +.PHONY: Test11018 +Test11018: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11018.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11018.hs + +.PHONY: Test11321 +Test11321: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11321.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11321.hs + +.PHONY: Test11332 +Test11332: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11332.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11332.hs + +.PHONY: Test11430 +Test11430: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11430.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test11430.hs + +.PHONY: Test12417 +Test12417: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test12417.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test12417.hs + +.PHONY: Test13163 +Test13163: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test13163.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test13163.hs + +.PHONY: Test15303 +Test15303: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test15303.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test15303.hs + +.PHONY: Test16212 +Test16212: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16212.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16212.hs + +.PHONY: Test16230 +Test16230: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16230.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16230.hs + +.PHONY: Test16236 +Test16236: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16236.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16236.hs + +.PHONY: Test16279 +Test16279: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16279.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16279.hs + +.PHONY: Test17388 +Test17388: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17388.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17388.hs + +.PHONY: Test17519 +Test17519: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17519.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test17519.hs + +.PHONY: Test15242 +Test15242: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test15242.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test15242.hs + +.PHONY: AnnotationLet +AnnotationLet: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" AnnotationLet.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" AnnotationLet.hs + +.PHONY: TestBoolFormula +TestBoolFormula: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" TestBoolFormula.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" TestBoolFormula.hs + +.PHONY: BundleExport +BundleExport: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" BundleExport.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" BundleExport.hs + +.PHONY: AnnotationTuple +AnnotationTuple: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" AnnotationTuple.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" AnnotationTuple.hs + +.PHONY: ListComprehensions +ListComprehensions: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" ListComprehensions.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" ListComprehensions.hs + +.PHONY: load-main +load-main: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" load-main.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" load-main.hs + +.PHONY: PprRecordDotSyntax1 +PprRecordDotSyntax1: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax1.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax1.hs + +.PHONY: PprRecordDotSyntax2 +PprRecordDotSyntax2: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax2.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax2.hs + +.PHONY: PprRecordDotSyntax3 +PprRecordDotSyntax3: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax3.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax3.hs + +.PHONY: PprRecordDotSyntax4 +PprRecordDotSyntax4: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax4.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntax4.hs + +.PHONY: PprRecordDotSyntaxA +PprRecordDotSyntaxA: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntaxA.hs + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" PprRecordDotSyntaxA.hs diff --git a/testsuite/tests/printer/Ppr001.hs b/testsuite/tests/printer/Ppr001.hs index 5277da5abf..4e29075999 100644 --- a/testsuite/tests/printer/Ppr001.hs +++ b/testsuite/tests/printer/Ppr001.hs @@ -1,5 +1,6 @@ -module Ppr001 where +module Ppr001 where +-- This is the main function main = putStrLn "hello" foo x = y + 3 diff --git a/testsuite/tests/printer/Ppr002a.hs b/testsuite/tests/printer/Ppr002a.hs new file mode 100644 index 0000000000..d8007d1632 --- /dev/null +++ b/testsuite/tests/printer/Ppr002a.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE Arrows #-} + +import Control.Arrow +import qualified Control.Category as Cat + +addA :: Arrow a => a b Int -> a b Int -> a b Int +addA f g = proc x -> do + y <- f -< x + z <- g -< x + returnA -< y + z + +newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } + +instance Cat.Category Circuit where + id = Circuit $ \a -> (Cat.id, a) + (.) = dot + where + (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> + let (cir1', b) = cir1 a + (cir2', c) = cir2 b + in (cir2' `dot` cir1', c) + +instance Arrow Circuit where + arr f = Circuit $ \a -> (arr f, f a) + first (Circuit cir) = Circuit $ \(b, d) -> + let (cir', c) = cir b + in (first cir', (c, d)) + +-- | Accumulator that outputs a value determined by the supplied function. +accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b +accum acc f = Circuit $ \input -> + let (output, acc') = input `f` acc + in (accum acc' f, output) + +-- | Accumulator that outputs the accumulator value. +accum' :: b -> (a -> b -> b) -> Circuit a b +accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) + +total :: Num a => Circuit a a +total = accum' 0 (+) + +mean3 :: Fractional a => Circuit a a +mean3 = proc value -> do + (t, n) <- (| (&&&) (total -< value) (total -< 1) |) + returnA -< t / n diff --git a/testsuite/tests/printer/Ppr003.hs b/testsuite/tests/printer/Ppr003.hs index 2cd738e4fe..9b72c50b05 100644 --- a/testsuite/tests/printer/Ppr003.hs +++ b/testsuite/tests/printer/Ppr003.hs @@ -1,4 +1,4 @@ -main = putStrLn "hello" +module Ppr003 where foo x = case x of diff --git a/testsuite/tests/printer/Ppr004.hs b/testsuite/tests/printer/Ppr004.hs index 797d36106a..2ee72efeb1 100644 --- a/testsuite/tests/printer/Ppr004.hs +++ b/testsuite/tests/printer/Ppr004.hs @@ -2,14 +2,15 @@ {-# LANGUAGE GADTs #-} -- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example +module Ppr004 where import qualified Data.IntMap import Prelude hiding (lookup) import Data.Char (ord) class GMapKey k where - data GMap k :: * -> * - empty :: GMap k v + data GMap k :: * -> * + empty :: GMap k v lookup :: k -> GMap k v -> Maybe v insert :: k -> v -> GMap k v -> GMap k v diff --git a/testsuite/tests/printer/Ppr008.hs b/testsuite/tests/printer/Ppr008.hs index b5b99e501c..2208a82ff4 100644 --- a/testsuite/tests/printer/Ppr008.hs +++ b/testsuite/tests/printer/Ppr008.hs @@ -26,8 +26,6 @@ module Ppr008 , setNonBlockingFD ) where -#include "EventConfig.h" - import Foreign.ForeignPtr (ForeignPtr) import GHC.Base import GHC.Conc.Signal (Signal) @@ -45,12 +43,8 @@ import System.Posix.Internals (c_close, c_pipe, c_read, c_write, setCloseOnExec, setNonBlockingFD) import System.Posix.Types (Fd) -#if defined(HAVE_EVENTFD) import Foreign.C.Error (throwErrnoIfMinus1) import Foreign.C.Types (CULLong(..)) -#else -import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) -#endif data ControlMessage = CMsgWakeup | CMsgDie @@ -62,20 +56,13 @@ data ControlMessage = CMsgWakeup data Control = W { controlReadFd :: {-# UNPACK #-} !Fd , controlWriteFd :: {-# UNPACK #-} !Fd -#if defined(HAVE_EVENTFD) , controlEventFd :: {-# UNPACK #-} !Fd -#else - , wakeupReadFd :: {-# UNPACK #-} !Fd - , wakeupWriteFd :: {-# UNPACK #-} !Fd -#endif , didRegisterWakeupFd :: !Bool } deriving (Show) -#if defined(HAVE_EVENTFD) wakeupReadFd :: Control -> Fd wakeupReadFd = controlEventFd -{-# INLINE wakeupReadFd #-} -#endif +{-# INLINE wakeupReadFd #-} -- | Create the structure (usually a pipe) used for waking up the IO -- manager thread from another thread. @@ -92,23 +79,14 @@ newControl shouldRegister = allocaArray 2 $ \fds -> do setCloseOnExec wr return (rd, wr) (ctrl_rd, ctrl_wr) <- createPipe -#if defined(HAVE_EVENTFD) ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 setNonBlockingFD ev True setCloseOnExec ev when shouldRegister $ c_setIOManagerWakeupFd ev -#else - (wake_rd, wake_wr) <- createPipe - when shouldRegister $ c_setIOManagerWakeupFd wake_wr -#endif return W { controlReadFd = fromIntegral ctrl_rd , controlWriteFd = fromIntegral ctrl_wr -#if defined(HAVE_EVENTFD) - , controlEventFd = fromIntegral ev -#else , wakeupReadFd = fromIntegral wake_rd , wakeupWriteFd = fromIntegral wake_wr -#endif , didRegisterWakeupFd = shouldRegister } @@ -122,12 +100,8 @@ closeControl w = do _ <- c_close . fromIntegral . controlReadFd $ w _ <- c_close . fromIntegral . controlWriteFd $ w when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1) -#if defined(HAVE_EVENTFD) - _ <- c_close . fromIntegral . controlEventFd $ w -#else _ <- c_close . fromIntegral . wakeupReadFd $ w _ <- c_close . fromIntegral . wakeupWriteFd $ w -#endif return () io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 @@ -164,18 +138,9 @@ readControlMessage ctrl fd return $ CMsgSignal fp s' where wakeupBufferSize = -#if defined(HAVE_EVENTFD) - 8 -#else 4096 -#endif sendWakeup :: Control -> IO () -#if defined(HAVE_EVENTFD) -sendWakeup c = - throwErrnoIfMinus1_ "sendWakeup" $ - c_eventfd_write (fromIntegral (controlEventFd c)) 1 -#else sendWakeup c = do n <- sendMessage (wakeupWriteFd c) CMsgWakeup case n of @@ -184,7 +149,6 @@ sendWakeup c = do errno <- getErrno when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ throwErrno "sendWakeup" -#endif sendDie :: Control -> IO () sendDie c = throwErrnoIfMinus1_ "sendDie" $ @@ -198,14 +162,6 @@ sendMessage fd msg = alloca $ \p -> do CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" fromIntegral `fmap` c_write (fromIntegral fd) p 1 -#if defined(HAVE_EVENTFD) -foreign import ccall unsafe "sys/eventfd.h eventfd" - c_eventfd :: CInt -> CInt -> IO CInt - -foreign import ccall unsafe "sys/eventfd.h eventfd_write" - c_eventfd_write :: CInt -> CULLong -> IO CInt -#endif - foreign import ccall unsafe "setIOManagerWakeupFd" c_setIOManagerWakeupFd :: CInt -> IO () diff --git a/testsuite/tests/printer/Ppr011.hs b/testsuite/tests/printer/Ppr011.hs index b967e247b6..84af1ed52a 100644 --- a/testsuite/tests/printer/Ppr011.hs +++ b/testsuite/tests/printer/Ppr011.hs @@ -8,8 +8,8 @@ data Foo = A | C -- | data_or_newtype capi_ctype tycl_hdr constrs deriving -data {-# Ctype "Foo" "bar" #-} F1 = F1 -data {-# Ctype "baz" #-} Eq a => F2 a = F2 a +data {-# Ctype "Foo" "bar" #-} F1 = F1 +data {-# Ctype "baz" #-} Eq a => F2 a = F2 a data (Eq a,Ord a) => F3 a = F3 Int a @@ -18,10 +18,11 @@ data F4 a = forall x y. (Eq x,Eq y) => F4 a x y data G1 a :: * where - G1A, G1B :: Int -> G1 a - G1C :: Double -> G1 a + G1A, G1B :: Int -> G1 a + G1C :: G1 a -> G1 a + G1D :: G1 a -> (Int -> G1 a) -data G2 a :: * where +data G2 a :: * where G2A :: { g2a :: a, g2b :: Int } -> G2 a G2C :: Double -> G2 a @@ -32,3 +33,13 @@ data (Eq a,Ord a) => G3 a = G3 , g3B :: Bool , g3a :: a } deriving (Eq,Ord) + +data G4 a :: * where + G4A, G4B :: Int -> G4 a + G4C :: {- A -} G4 {- B -}a {- C -} -> {- D -} G4 {- E -}a + G4D :: {- A -}G4 {- B -}a {- C -} -> {- D -}( {- E -}Int{- F -} -> {- G -}G4 {- H -}a {- I -}) + +ff x = + case x of + 1 -> True + _ -> False diff --git a/testsuite/tests/printer/Ppr012.hs b/testsuite/tests/printer/Ppr012.hs index 04828cf343..9ffb691b50 100644 --- a/testsuite/tests/printer/Ppr012.hs +++ b/testsuite/tests/printer/Ppr012.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ExplicitForAll #-} + module Dead1(foo) where foo :: Int -> Int @@ -38,3 +40,5 @@ this work right. Look at the simplifier output just before strictness analysis; there should be a binding for 'foo', but for nothing else. -} + +{-# RULES "example" forall a. forall (x :: a). id x = x #-} diff --git a/testsuite/tests/printer/Ppr019.hs b/testsuite/tests/printer/Ppr019.hs index c934cc5ccc..3591239a77 100644 --- a/testsuite/tests/printer/Ppr019.hs +++ b/testsuite/tests/printer/Ppr019.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, - CPP #-} -#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE RoleAnnotations #-} -#endif {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -34,9 +31,6 @@ import Control.Monad.ST ( RealWorld, stToIO ) import Foreign.Ptr ( Ptr, FunPtr ) import Foreign.StablePtr ( StablePtr ) -#if __GLASGOW_HASKELL__ < 711 -import Data.Ix -#endif import Data.Array.Base import GHC.IOArray (IOArray(..)) @@ -54,10 +48,8 @@ import GHC.IOArray (IOArray(..)) -- newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Typeable -#if __GLASGOW_HASKELL__ >= 708 -- Both parameters have class-based invariants. See also #9220. type role IOUArray nominal nominal -#endif instance Eq (IOUArray i e) where IOUArray s1 == IOUArray s2 = s1 == s2 @@ -377,11 +369,7 @@ castIOUArray (IOUArray marr) = stToIO $ do return (IOUArray marr') {-# INLINE unsafeThawIOUArray #-} -#if __GLASGOW_HASKELL__ >= 711 unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e) -#else -unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) -#endif unsafeThawIOUArray arr = stToIO $ do marr <- unsafeThawSTUArray arr return (IOUArray marr) @@ -390,11 +378,7 @@ unsafeThawIOUArray arr = stToIO $ do "unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray #-} -#if __GLASGOW_HASKELL__ >= 711 thawIOUArray :: UArray ix e -> IO (IOUArray ix e) -#else -thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) -#endif thawIOUArray arr = stToIO $ do marr <- thawSTUArray arr return (IOUArray marr) @@ -404,22 +388,14 @@ thawIOUArray arr = stToIO $ do #-} {-# INLINE unsafeFreezeIOUArray #-} -#if __GLASGOW_HASKELL__ >= 711 unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e) -#else -unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) -#endif unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) {-# RULES "unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray #-} -#if __GLASGOW_HASKELL__ >= 711 freezeIOUArray :: IOUArray ix e -> IO (UArray ix e) -#else -freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) -#endif freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) {-# RULES diff --git a/testsuite/tests/printer/Ppr024.hs b/testsuite/tests/printer/Ppr024.hs index cccd8b163c..53f4820841 100644 --- a/testsuite/tests/printer/Ppr024.hs +++ b/testsuite/tests/printer/Ppr024.hs @@ -13,6 +13,12 @@ x `f` y = x (\\\) :: (Eq a) => [a] -> [a] -> [a] (\\\) xs ys = xs +(\\\) :: ((Eq a)) => [a] -> [a] -> [a] +(\\\) xs ys = xs + +(\\\) :: Eq a => [a] -> [a] -> [a] +(\\\) xs ys = xs + g x = x + if True then 1 else 2 h x = x + 1::Int diff --git a/testsuite/tests/printer/Ppr025.hs b/testsuite/tests/printer/Ppr025.hs index c198e18a41..e6637a3793 100644 --- a/testsuite/tests/printer/Ppr025.hs +++ b/testsuite/tests/printer/Ppr025.hs @@ -7,6 +7,9 @@ operator = describe "Operators on ProcessA"$ it "acts like local variable with hold." $ do let + foo = bar $ + do + return 4 pa = proc evx -> do (\evy -> hold 10 -< evy) diff --git a/testsuite/tests/printer/Ppr037.hs b/testsuite/tests/printer/Ppr037.hs index 1ece4394f9..30893a9e1e 100644 --- a/testsuite/tests/printer/Ppr037.hs +++ b/testsuite/tests/printer/Ppr037.hs @@ -34,8 +34,9 @@ import Data.Type.Equality -- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', -- then it defaults to a use of '(==)', from @Data.Type.Equality@. class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where - type (:==) (x :: a) (y :: a) :: Bool - type (:/=) (x :: a) (y :: a) :: Bool + type (:==) (x :: a) ( y :: a) :: Bool + type (:/=) ( (x :: a) ) (y :: a ) :: Bool + type {- a -} ({- b -}:/:{- c -}) {- d -} ({- e -}x {- f -} :: {- g -} a {- h -}) {- i -} ({- j -}y {- k -}::{- l -} a{- m -}){- n -} ::{- o -} Bool {- p -} type (x :: a) :== (y :: a) = x == y type (x :: a) :/= (y :: a) = Not (x :== y) diff --git a/testsuite/tests/printer/Ppr049.hs b/testsuite/tests/printer/Ppr049.hs new file mode 100644 index 0000000000..9a008ebabd --- /dev/null +++ b/testsuite/tests/printer/Ppr049.hs @@ -0,0 +1,161 @@ +-- | HTML output for documentation package index. + +module Ppr049 ( + htmlPage +) where + +import Control.Monad +import Data.Char (isAlpha, toUpper) +import Data.List +import Data.Ord +import Data.Time +import Data.Version +import qualified Data.Map as M +import System.FilePath +import System.Locale +import Text.Html + +import Distribution.DocIdx.Common +import Distribution.DocIdx.Config +import Distribution.GhcPkgList + +-- | Project homepage, for footer. +homePage :: String +homePage = "http://hackage.haskell.org/package/docidx" + +-- | Create and render entire page. +htmlPage :: DocIdxCfg -> PackageMap HaddockInfo -> UTCTime -> String +htmlPage config pkgs now = renderHtml [htmlHeader, htmlBody] + where htmlHeader = header << ((thetitle << pageTitle config) : fav : css) + fav = thelink ! [rel "shortcut icon", href $ favIcon config] << noHtml + css = map oneCss (pageCss config) + oneCss cp = thelink ! [rel "stylesheet", + thetype "text/css", href cp] << noHtml + htmlBody = body << (title' ++ toc ++ secs ++ nowFoot) + where title' = [h2 << "Local packages with docs"] + toc = [htmlToc config am] + secs = concatMap (uncurry htmlPkgsAlpha) $ M.assocs am + am = alphabetize pkgs + now' = formatTime defaultTimeLocale rfc822DateFormat now + nowFoot = [p ! [theclass "toc"] $ + stringToHtml ("Page rendered " ++ now' ++ " by ") + +++ (anchor ! [href homePage] << + stringToHtml appName)] + +-- | An AlphaMap groups packages together by their name's first character. +type AlphaMap = M.Map Char (PackageMap HaddockInfo) + +-- | Group packages together by their name's first character. +alphabetize :: PackageMap HaddockInfo -> AlphaMap +alphabetize = foldr addAlpha M.empty + where addAlpha (n, vs) = M.insertWith (++) c [(n, vs)] + where c = if isAlpha c' then c' else '\0' + c' = toUpper $ head n + +-- | Generate the table of contents. +htmlToc :: DocIdxCfg -> AlphaMap -> Html +htmlToc config am = + p ! [theclass "toc"] << tocHtml (alphaItems ++ tocExtras config) + where tocHtml = intersperse bull . concatMap tocItemHtml + alphaItems = map (\k -> TocItem [k] ('#':[k])) $ sort $ M.keys am + +-- | Render toc elements to HTML. +tocItemHtml :: TocItem -> [Html] +tocItemHtml (TocItem nm path) = [anchor ! [href path] << nm] +tocItemHtml TocSeparator = [mdash] +tocItemHtml TocNewline = [br] -- Hmmm... you still get the bullets? + +-- | Render a collection of packages with the same first character. +htmlPkgsAlpha :: Char -> PackageMap HaddockInfo -> [Html] +htmlPkgsAlpha c pm = [heading, packages] + where heading = h3 ! [theclass "category"] << anchor ! [name [c]] << [c] + packages = ulist ! [theclass "packages"] << + map (uncurry htmlPkg) pm' + pm' = sortBy (comparing (map toUpper . fst)) pm + +-- | Render a particularly-named package (all versions of it). +htmlPkg :: String -> VersionMap HaddockInfo -> Html +htmlPkg nm vs = li << pvsHtml (flattenPkgVersions nm vs) + +-- | Everything we want to know about a particular version of a +-- package, nicely flattened and ready to use. (Actually, we'd also +-- like to use the synopsis, but this isn't exposed through the Cabal +-- library, sadly. We could conceivably grab it from the haddock docs +-- (and hackage for packages with no local docs) but this +-- seems excessive so for now we forget about it. +data PkgVersion = PkgVersion { + pvName ::String + , pvSynopsis :: Maybe String + , pvVersion :: Version + , pvExposed :: Bool + , pvHaddocks :: Maybe FilePath + } deriving (Eq, Ord, Show) + +-- | Flatten a given package's various versions into a list of +-- PkgVersion values, which is much nicer to iterate over when +-- building the HTML for this package. +flattenPkgVersions :: String -> VersionMap HaddockInfo -> [PkgVersion] +flattenPkgVersions nm vs = concatMap (uncurry flatten') $ reverse vs + where flatten' :: Version -> [VersionInfo HaddockInfo] -> [PkgVersion] + -- We reverse here to put user versions of pkgs before + -- identically versioned global versions. + flatten' v = concatMap (uncurry flatten3) . reverse + where flatten3 :: Bool -> [HaddockInfo] -> [PkgVersion] + flatten3 ex [] = [PkgVersion nm Nothing v ex Nothing] + flatten3 ex ps = map (mkPv nm v ex) ps + +-- | Construct a PkgVersion from information about a single version of +-- a package. +mkPv :: String -> Version -> Bool -> HaddockInfo -> PkgVersion +mkPv nm v ex Nothing = PkgVersion nm Nothing v ex Nothing +mkPv nm v ex (Just (hp, syn)) = PkgVersion nm (Just syn) v ex (Just hp) + +-- | Render the HTML for a list of versions of (we presume) the same +-- package. +pvsHtml :: [PkgVersion] -> Html +pvsHtml pvs = pvHeader (head pvs) +++ spaceHtml +++ pvVersions pvs +++ + pvSyn pvs + +-- | Render the "header" part of some package's HTML: name (with link +-- to default version of local docs if available) and hackage link. +pvHeader :: PkgVersion -> [Html] +pvHeader pv = [maybeURL nme (pvHaddocks pv) + ,spaceHtml + ,anchor ! [href $ hackagePath pv] << extLinkArrow + ] + where nme = if not (pvExposed pv) then "(" ++ nm ++ ")" else nm + nm = pvName pv + +-- | Render HTML linking to the various versions of a package +-- installed, listed by version number only (name is implicit). +pvVersions :: [PkgVersion] -> Html +pvVersions [_] = noHtml -- Don't bother if there's only one version. +pvVersions pvs = stringToHtml "[" +++ + intersperse comma (map pvOneVer pvs) +++ + stringToHtml "]" + where pvOneVer pv = maybeURL (showVersion $ pvVersion pv) (pvHaddocks pv) + +-- | Render the synopsis of a package, if present in any of its versions. +pvSyn :: [PkgVersion] -> Html +pvSyn = maybe noHtml (\x -> mdash +++ stringToHtml x) . msum . map pvSynopsis + +-- | Render a URL if there's a path; otherwise, just render some text. +-- (Useful in cases where a package is installed but no documentation +-- was found: you'll still get the hackage link.) +maybeURL :: String -> Maybe String -> Html +maybeURL nm Nothing = stringToHtml nm +maybeURL nm (Just path) = anchor ! [href $ joinPath [path, "index.html"]] << nm + +-- | Compute the URL to a package's page on hackage. +hackagePath :: PkgVersion -> String +hackagePath pv = "http://hackage.haskell.org/package/" ++ pvTag + where pvTag = pvName pv ++ "-" ++ showVersion (pvVersion pv) + +-- Some primitives. + +bull, comma, extLinkArrow, mdash :: Html +bull = primHtml " • " +comma = stringToHtml ", " +extLinkArrow = primHtml "⬈" +mdash = primHtml " — " + diff --git a/testsuite/tests/printer/Ppr050.hs b/testsuite/tests/printer/Ppr050.hs new file mode 100644 index 0000000000..43943e94ae --- /dev/null +++ b/testsuite/tests/printer/Ppr050.hs @@ -0,0 +1,6 @@ +module Ppr050 where + +-- standalone kind signature +type (:::) :: Int + +type Ord :: a :: Foo diff --git a/testsuite/tests/printer/Ppr051.hs b/testsuite/tests/printer/Ppr051.hs new file mode 100644 index 0000000000..bdd083e98f --- /dev/null +++ b/testsuite/tests/printer/Ppr051.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE KindSignatures #-} +module Ppr051 where + +-- default declaration +default ( ) +default ( Int , Bool :: Int ) diff --git a/testsuite/tests/printer/Ppr052.hs b/testsuite/tests/printer/Ppr052.hs new file mode 100644 index 0000000000..cc4ee700c9 --- /dev/null +++ b/testsuite/tests/printer/Ppr052.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} +module Ppr052 where + +{-# ANN module (1 :: Int) #-} +{-# ANN module (1 :: Integer) #-} +{-# ANN module (1 :: Double) #-} +{-# ANN module $([| 1 :: Int |]) #-} +{-# ANN module "Hello" #-} +{-# ANN module (Just (1 :: Int)) #-} +{-# ANN module [1 :: Int, 2, 3] #-} +{-# ANN module ([1..10] :: [Integer]) #-} +{-# ANN module ''Foo #-} +{-# ANN module (-1 :: Int) #-} + +{-# ANN type Foo (1 :: Int) #-} +{-# ANN type Foo (1 :: Integer) #-} +{-# ANN type Foo (1 :: Double) #-} +{-# ANN type Foo $([| 1 :: Int |]) #-} +{-# ANN type Foo "Hello" #-} +{-# ANN type Foo (Just (1 :: Int)) #-} +{-# ANN type Foo [1 :: Int, 2, 3] #-} +{-# ANN type Foo ([1..10] :: [Integer]) #-} +{-# ANN type Foo ''Foo #-} +{-# ANN type Foo (-1 :: Int) #-} +data Foo = Bar Int + +{-# ANN f (1 :: Int) #-} +{-# ANN f (1 :: Integer) #-} +{-# ANN f (1 :: Double) #-} +{-# ANN f $([| 1 :: Int |]) #-} +{-# ANN f "Hello" #-} +{-# ANN f (Just (1 :: Int)) #-} +{-# ANN f [1 :: Int, 2, 3] #-} +{-# ANN f ([1..10] :: [Integer]) #-} +{-# ANN f 'f #-} +{-# ANN f (-1 :: Int) #-} +f x = x diff --git a/testsuite/tests/printer/Ppr053.hs b/testsuite/tests/printer/Ppr053.hs new file mode 100644 index 0000000000..f8a76298bb --- /dev/null +++ b/testsuite/tests/printer/Ppr053.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RecordWildCards #-} +module Scopes where + +-- Verify that evidence bound by patern +-- synonyms has correct scope +pattern LL :: Num a => a -> a +pattern LL x <- (subtract 1 -> x) + where + LL x = x + 1 + +data T = C { x :: Int, y :: Char } + +-- Verify that names generated from record construction +-- have correct scope +foo = C { x = 1 , y = 'a' } + +-- Verify that implicit paramters have correct scope +bar :: (?x :: Int) => Int +bar = ?x + 1 + +baz :: Int +baz = bar + ?x + where ?x = 2 + +-- Verify that variables bound in pattern +-- synonyms have the correct scope +pattern A a b = (a , b) + +-- Verify that record wildcards are in scope +sdaf :: T +sdaf = C{..} + where + x = 1 + y = 'a' diff --git a/testsuite/tests/printer/Ppr054.hs b/testsuite/tests/printer/Ppr054.hs new file mode 100644 index 0000000000..348d916a24 --- /dev/null +++ b/testsuite/tests/printer/Ppr054.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +module Ppr054 where + +import Data.Typeable +import GHC.StaticPtr + +main = putStr $ unlines $ map show names + where + names = + [ staticPtrInfo $ static g + , staticPtrInfo $ (static id :: StaticPtr (Int -> Int)) + , staticPtrInfo $ (p0 :: StaticPtr (Int -> Int)) + , staticPtrInfo $ (static method :: StaticPtr (Char -> Int)) + , staticPtrInfo $ (static t_field :: StaticPtr (T Int -> Int)) + ] + +g :: Int -> Int +g = id + +p0 :: Typeable a => StaticPtr (a -> a) +p0 = static (\x -> x) + +data T a = T { t_field :: a } + deriving Typeable + +class C1 a where + method :: a -> Int + +instance C1 Char where + method = const 0 diff --git a/testsuite/tests/printer/Ppr055.hs b/testsuite/tests/printer/Ppr055.hs new file mode 100644 index 0000000000..24963a7878 --- /dev/null +++ b/testsuite/tests/printer/Ppr055.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedSums #-} +module Ppr055 where + +import Language.Haskell.TH + +foo :: $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) + -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) +foo $(conP (unboxedSumDataName 1 2) [conP '() []]) + = $(conE (unboxedSumDataName 2 2) `appE` conE '()) +foo $(conP (unboxedSumDataName 2 2) [conP '() []]) + = $(conE (unboxedSumDataName 2 2) `appE` conE '()) + +foo2 :: (# () | () #) + -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) +foo2 (# () | #) = $(conE (unboxedSumDataName 2 2) `appE` conE '()) +foo2 $(conP (unboxedSumDataName 2 2) [conP '() []]) = (# | () #) + + +foo3 :: (# () | () | () | () #) -> Int +foo3 (# | | () | #) = 3 diff --git a/testsuite/tests/printer/PprRecordDotSyntax1.hs b/testsuite/tests/printer/PprRecordDotSyntax1.hs new file mode 100644 index 0000000000..19764deb99 --- /dev/null +++ b/testsuite/tests/printer/PprRecordDotSyntax1.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-} +-- For "higher kinded data" test. +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE RebindableSyntax #-} +module PprRecordDotSyntax1 where + +import Prelude + +-- Choice (C2a). + +import Data.Function -- for & +import Data.Functor.Identity + +class HasField x r a | x r -> a where + hasField :: r -> (a -> r, a) + +getField :: forall x r a . HasField x r a => r -> a +getField = snd . hasField @x -- Note: a.x = is getField @"x" a. + +setField :: forall x r a . HasField x r a => r -> a -> r +setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b. + +-- 'Foo' has 'foo' field of type 'Bar' +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +instance HasField "foo" Foo Bar where + hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r) + +-- 'Bar' has a 'bar' field of type 'Baz' +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +instance HasField "bar" Bar Baz where + hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r) + +-- 'Baz' has a 'baz' field of type 'Quux' +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +instance HasField "baz" Baz Quux where + hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r) + +-- 'Quux' has a 'quux' field of type 'Int' +data Quux = Quux { quux :: Int } deriving (Show, Eq) +instance HasField "quux" Quux Int where + hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r) + +-- 'Corge' has a '&&&' field of type 'Int' +data Corge = Corge { (&&&) :: Int } deriving (Show, Eq) +instance HasField "&&&" Corge Int where + hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r) +-- Note : Dot notation is not available for fields with operator +-- names. + +-- 'Grault' has two fields 'f' and 'g' of type 'Foo'. +data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq) +instance HasField "f" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r) +instance HasField "g" Grault Foo where + hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r) + +-- "Higher kinded data" +-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/) +type family H f a where + H Identity a = a + H f a = f a +data P f = P + { n :: H f String + } +-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34. +instance (a ~ H f String) => HasField "n" (P f) a where + hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + let b = Corge{ (&&&) = 12 }; + let c = Grault { + f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } } + , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } } + } + + -- A "selector" is an expression like '(.a)' or '(.a.b)'. + putStrLn "-- selectors:" + print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } } + print $ (.foo.bar.baz) a -- Quux { quux = 42 } + print $ (.foo.bar.baz.quux) a -- 42 + print $ ((&&&) b) -- 12 + -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’ + print $ getField @"&&&" b -- 12 + + -- A "selection" is an expression like 'r.a' or '(f r).a.b'. + putStrLn "-- selections:" + print $ a.foo.bar.baz.quux -- 42 + print $ a.foo.bar.baz -- Quux { quux = 42 } + print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } } + print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (const "hello") a.foo -- f r.x means f (r.x) + -- print $ f a .foo -- f r .x is illegal + print $ (const "hello") (id a).foo -- f (g r).x means f ((g r).x) + -- print $ f (g a) .foo -- f (g r) .x is illegal + print $ a.foo + & (.bar.baz.quux) -- 42 + print $ (a.foo + ).bar.baz.quux -- 42 + print $ (+) a.foo.bar.baz.quux 1 -- 43 + print $ (+) (id a).foo.bar.baz.quux 1 -- 43 + print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43 + + -- An "update" is an expression like 'r{ a.b = 12 }'. + putStrLn "-- updates:" + print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 } + print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } } + let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } } + print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } } + print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } } + print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } } + print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } } + + -- A "punned update" is an expression like 'r{ a.b }' (where it is + -- understood that 'b' is a variable binding in the environment of + -- the field update - enabled only when the extension + -- 'NamedFieldPuns' is in effect). + putStrLn "-- punned updates:" + let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } } + print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } } + print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4 + f <- pure a + g <- pure a + print $ c{ f } -- 42, 1 + print $ c{ f, g } -- 42, 42 + print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4 + + putStrLn "-- misc:" + -- Higher kinded test. + let p = P { n = Just "me" } :: P Maybe + Just me <- pure p.n + putStrLn $ me diff --git a/testsuite/tests/printer/PprRecordDotSyntax2.hs b/testsuite/tests/printer/PprRecordDotSyntax2.hs new file mode 100644 index 0000000000..8677914e46 --- /dev/null +++ b/testsuite/tests/printer/PprRecordDotSyntax2.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoRebindableSyntax #-} + +module PprRecordDotSyntax2 where + +data Foo = Foo { foo :: Bar } deriving (Show, Eq) +data Bar = Bar { bar :: Baz } deriving (Show, Eq) +data Baz = Baz { baz :: Quux } deriving (Show, Eq) +data Quux = Quux { quux :: Int } deriving (Show, Eq) + +main = do + let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } } + + -- A "selector" is an expression like '(.a)' or '(.a.b)'. + putStrLn "-- selectors:" + print $ (.foo) a -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } } + print $ (.foo.bar.baz) a -- Quux { quux = 42 } + print $ (.foo.bar.baz.quux) a -- 42 + + -- A "selection" is an expression like 'r.a' or '(f r).a.b'. + putStrLn "-- selections:" + print $ a.foo.bar.baz.quux -- 42 + print $ a.foo.bar.baz -- Quux { quux = 42 } + print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } } + print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } } + + -- An "update" is an expression like 'r{ a.b = 12 }'. + -- + -- We don't support these (in the case Rebindable Syntax is off) yet + -- (waiting on HasField support). + -- + -- Regular updates are fine though! + print $ a{foo=(foo a){bar = (bar (foo a)){baz = (baz (bar (foo a))){quux = quux (baz (bar (foo a))) + 1}}}} + print $ a{foo=(a.foo){bar = (a.foo.bar){baz = (a.foo.bar.baz){quux = a.foo.bar.baz.quux + 1}}}} diff --git a/testsuite/tests/printer/PprRecordDotSyntax3.hs b/testsuite/tests/printer/PprRecordDotSyntax3.hs new file mode 100644 index 0000000000..6056af152a --- /dev/null +++ b/testsuite/tests/printer/PprRecordDotSyntax3.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module PprRecordDotSyntax3 where + +import qualified RecordDotSyntaxA as A + + +main = do + print $ id A.n -- Foo {foo = 2}; f M.x means f (M.x) + print $ id A.n.foo -- 2; f M.n.x means f (M.n.x) + + let bar = A.Foo {A.foo = 1} + print $ bar.foo -- Ok; 1 + -- print $ bar.A.foo -- parse error on input 'A.foo' diff --git a/testsuite/tests/printer/PprRecordDotSyntax4.hs b/testsuite/tests/printer/PprRecordDotSyntax4.hs new file mode 100644 index 0000000000..6dda73d68c --- /dev/null +++ b/testsuite/tests/printer/PprRecordDotSyntax4.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module PprRecordDotSyntax4 where + +import qualified RecordDotSyntaxA as A + +main = do + let bar = A.Foo {A.foo = 1} + print $ bar{A.foo = 2} -- Qualified labels ok in regular updates. diff --git a/testsuite/tests/printer/PprRecordDotSyntaxA.hs b/testsuite/tests/printer/PprRecordDotSyntaxA.hs new file mode 100644 index 0000000000..907d6a23f6 --- /dev/null +++ b/testsuite/tests/printer/PprRecordDotSyntaxA.hs @@ -0,0 +1,6 @@ +module RecordDotSyntaxA where + +data Foo = Foo { foo :: Int } deriving Show + +n :: Foo +n = Foo {foo = 2} diff --git a/testsuite/tests/printer/RdrNames.hs b/testsuite/tests/printer/RdrNames.hs new file mode 100644 index 0000000000..5124bcccde --- /dev/null +++ b/testsuite/tests/printer/RdrNames.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-} +module RdrNames where + +import Data.Monoid + +-- --------------------------------------------------------------------- + +-- | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) +-- [mj AnnType $1,mj AnnVal $2] } + +-- Tested in DataFamilies.hs + +-- --------------------------------------------------------------------- + +-- | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +ff = (RdrNames.:::) 0 1 + + +-- --------------------------------------------------------------------- + +-- | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +data FF = ( ::: ) Int Int + +-- --------------------------------------------------------------------- + +-- | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +data GG = GG Int Int +gg = 0 ` GG ` 1 + +-- --------------------------------------------------------------------- + +-- | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +vv = "a" ` mappend ` "b" + +-- --------------------------------------------------------------------- + +-- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +vvq = "a" ` Data.Monoid.mappend ` "b" + +-- --------------------------------------------------------------------- + +-- | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) +-- [mo $1,mc $2] } +-- Tested in Vect.hs + +-- --------------------------------------------------------------------- + +-- | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) +-- [mo $1,mc $2] } +-- Tested in Vect.hs + +-- --------------------------------------------------------------------- + +-- | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple +-- (snd $2 + 1))) +-- (mo $1:mc $3:(mcommas (fst $2))) } +ng :: (, , ,) Int Int Int Int +ng = undefined + +-- --------------------------------------------------------------------- + +-- | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple +-- (snd $2 + 1))) +-- (mo $1:mc $3:(mcommas (fst $2))) } +-- Tested in Unboxed.hs + +-- --------------------------------------------------------------------- + +-- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) +-- [mo $1,mj AnnRarrow $2,mc $3] } + +ft :: (->) a b +ft = undefined + +fp :: ( -> ) a b +fp = undefined + +type family F a :: * -> * -> * +type instance F Int = (->) +type instance F Char = ( , ) + +-- --------------------------------------------------------------------- + +-- | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] } +lt :: [] a +lt = undefined + +-- --------------------------------------------------------------------- + +-- | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } + +-- GHC source indicates this constuctor is only available in PrelPArr +-- ltp :: [::] a +-- ltp = undefined + +-- --------------------------------------------------------------------- + +-- | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) +-- [mo $1,mj AnnTildehsh $2,mc $3] } + +-- primitive type? +-- Refl Int :: ~# * Int Int +-- Refl Maybe :: ~# (* -> *) Maybe Maybe + +-- | A data constructor used to box up all unlifted equalities +-- +-- The type constructor is special in that GHC pretends that it +-- has kind (? -> ? -> Fact) rather than (* -> * -> *) +data (~) a b = Eq# ((~#) a b) +data ( ~ ) a b = Eq# (( ~# ) a b) + +data Coercible a b = MkCoercible ((~#) a b) + + +-- --------------------------------------------------------------------- + +-- | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +-- TBD + +-- --------------------------------------------------------------------- + +-- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) +-- [mo $1,mj AnnTilde $2,mc $3] } + +-- --------------------------------------------------------------------- + +-- tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } + +-- --------------------------------------------------------------------- + + +{- From #haskell-emacs +gracjan> did you know that this is legal haskell: +<gracjan> (+ 1) ` fmap {- -} ` [1,2,3] +-} +xxx = (+ 1) ` fmap {- -} ` [1,2,3] diff --git a/testsuite/tests/ghc-api/annotations/StarBinderAnns.hs b/testsuite/tests/printer/StarBinderAnns.hs index 4b69f44d66..4b69f44d66 100644 --- a/testsuite/tests/ghc-api/annotations/StarBinderAnns.hs +++ b/testsuite/tests/printer/StarBinderAnns.hs diff --git a/testsuite/tests/printer/T13050p.hs b/testsuite/tests/printer/T13050p.hs index d40c476dcd..351da3563c 100644 --- a/testsuite/tests/printer/T13050p.hs +++ b/testsuite/tests/printer/T13050p.hs @@ -4,3 +4,6 @@ f, g, q :: Int -> Int -> Int f x y = _ x y g x y = x `_` y q x y = x `_a` y + +h x y = x ` _ ` y +r x y = x ` _a ` y diff --git a/testsuite/tests/printer/T13199.stdout b/testsuite/tests/printer/T13199.stdout index 6ccc1f10f0..b1cb7c384f 100644 --- a/testsuite/tests/printer/T13199.stdout +++ b/testsuite/tests/printer/T13199.stdout @@ -19,9 +19,9 @@ T13199.hs:33:2-30: Splicing declarations T13199.hs:36:2-29: Splicing declarations [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int) T13199.hs:38:2-59: Splicing declarations - [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |] + [d| l = case Just 'a' of Just a -> Just ((\ x -> x) a) |] ======> - l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } + l = case Just 'a' of Just a -> Just ((\ x -> x) a) T13199.ppr.hs:11:2-42: Splicing declarations [d| instance C (Maybe a) (Maybe b) c |] ======> @@ -42,7 +42,31 @@ T13199.ppr.hs:16:2-29: Splicing declarations [d| j B {aa = a} = True |] ======> j B {aa = a} = True T13199.ppr.hs:17:2-29: Splicing declarations [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int) -T13199.ppr.hs:18:2-64: Splicing declarations - [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |] +T13199.ppr.hs:18:2-60: Splicing declarations + [d| l = case Just 'a' of Just a -> Just ((\ x -> x) a) |] ======> - l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } + l = case Just 'a' of Just a -> Just ((\ x -> x) a) +T13199.ppr.hs:(14,2)-(15,7): Splicing declarations + [d| instance C (Maybe a) (Maybe b) c |] + ======> + instance C (Maybe a) (Maybe b) c +T13199.ppr.hs:21:2-45: Splicing declarations + [d| g (a :: (Int -> Int) -> Int) = True |] + ======> + g (a :: (Int -> Int) -> Int) = True +T13199.ppr.hs:24:2-28: Splicing declarations + [d| h (id -> x) = True |] ======> h (id -> x) = True +T13199.ppr.hs:27:2-38: Splicing declarations + [d| f (Just (Just False)) = True |] + ======> + f (Just (Just False)) = True +T13199.ppr.hs:30:2-34: Splicing declarations + [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True +T13199.ppr.hs:33:2-30: Splicing declarations + [d| j B {aa = a} = True |] ======> j B {aa = a} = True +T13199.ppr.hs:36:2-29: Splicing declarations + [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int) +T13199.ppr.hs:38:2-59: Splicing declarations + [d| l = case Just 'a' of Just a -> Just ((\ x -> x) a) |] + ======> + l = case Just 'a' of Just a -> Just ((\ x -> x) a) diff --git a/testsuite/tests/printer/T13550.stdout b/testsuite/tests/printer/T13550.stdout index 7f74e48895..b3173f8612 100644 --- a/testsuite/tests/printer/T13550.stdout +++ b/testsuite/tests/printer/T13550.stdout @@ -20,3 +20,14 @@ T13550.ppr.hs:(5,2)-(8,70): Splicing declarations type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) data family Bar a b data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) +T13550.ppr.hs:(6,2)-(11,7): Splicing declarations + [d| type family Foo a b + data family Bar a b + + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |] + ======> + type family Foo a b + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + data family Bar a b + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) diff --git a/testsuite/tests/printer/T13942.stdout b/testsuite/tests/printer/T13942.stdout index f40a71bf0f..8c80afa15f 100644 --- a/testsuite/tests/printer/T13942.stdout +++ b/testsuite/tests/printer/T13942.stdout @@ -10,3 +10,9 @@ T13942.ppr.hs:(4,2)-(5,23): Splicing declarations ======> f :: Either Int (Int -> Int) f = undefined +T13942.ppr.hs:(5,2)-(7,7): Splicing declarations + [d| f :: Either Int (Int -> Int) + f = undefined |] + ======> + f :: Either Int (Int -> Int) + f = undefined diff --git a/testsuite/tests/printer/T14289.stdout b/testsuite/tests/printer/T14289.stdout index b11a3bf063..ab7eb04a84 100644 --- a/testsuite/tests/printer/T14289.stdout +++ b/testsuite/tests/printer/T14289.stdout @@ -14,3 +14,19 @@ T14289.ppr.hs:(7,2)-(9,26): Splicing declarations data Foo a = Foo a deriving (C a) +T14289.hs:10:2-43: Splicing declarations + [d| data Foo a + = Foo a + deriving (C a) |] + ======> + data Foo a + = Foo a + deriving (C a) +T14289.ppr.hs:10:2-43: Splicing declarations + [d| data Foo a + = Foo a + deriving (C a) |] + ======> + data Foo a + = Foo a + deriving (C a) diff --git a/testsuite/tests/printer/T14289b.stdout b/testsuite/tests/printer/T14289b.stdout index 5c6e0f7474..e3d163aa86 100644 --- a/testsuite/tests/printer/T14289b.stdout +++ b/testsuite/tests/printer/T14289b.stdout @@ -14,3 +14,19 @@ T14289b.ppr.hs:(8,2)-(10,30): Splicing declarations data Foo a = Foo a deriving (C y z) +T14289b.hs:11:2-47: Splicing declarations + [d| data Foo a + = Foo a + deriving (y `C` z) |] + ======> + data Foo a + = Foo a + deriving (C y z) +T14289b.ppr.hs:11:2-47: Splicing declarations + [d| data Foo a + = Foo a + deriving (y `C` z) |] + ======> + data Foo a + = Foo a + deriving (C y z) diff --git a/testsuite/tests/printer/T14289c.stdout b/testsuite/tests/printer/T14289c.stdout index 287793b6ea..66704d3402 100644 --- a/testsuite/tests/printer/T14289c.stdout +++ b/testsuite/tests/printer/T14289c.stdout @@ -14,3 +14,19 @@ T14289c.ppr.hs:(7,2)-(9,28): Splicing declarations data Foo a = Foo a deriving (a ~ a) +T14289c.hs:9:2-45: Splicing declarations + [d| data Foo a + = Foo a + deriving (a ~ a) |] + ======> + data Foo a + = Foo a + deriving (a ~ a) +T14289c.ppr.hs:9:2-45: Splicing declarations + [d| data Foo a + = Foo a + deriving (a ~ a) |] + ======> + data Foo a + = Foo a + deriving (a ~ a) diff --git a/testsuite/tests/printer/T18247a.hs b/testsuite/tests/printer/T18247a.hs new file mode 100644 index 0000000000..637be002cc --- /dev/null +++ b/testsuite/tests/printer/T18247a.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PatternSynonyms #-} +module T18247a where + +import Control.Monad () +import qualified Data.Sequence as Seq () +import T18247b + ( T, + Nat(Z, S), + Showable(..), + Type, + pattern ExNumPat, + pattern Head, + pattern Single, + pattern Pair, + pattern One, + pattern Succ, + pattern (:>), + pattern (:<), + pattern Empty, + pattern Int, + pattern Arrow, + pattern P ) diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr index c944f648dc..b2f3aef22d 100644 --- a/testsuite/tests/printer/T18791.stderr +++ b/testsuite/tests/printer/T18791.stderr @@ -1,21 +1,61 @@ ==================== Parser AST ==================== -({ T18791.hs:1:1 } +(L + { T18791.hs:1:1 } (HsModule + (ApiAnn + (Anchor + { T18791.hs:1:1 } + (UnchangedAnchor)) + (AnnsModule + [(AddApiAnn AnnModule (AR { T18791.hs:2:1-6 })) + ,(AddApiAnn AnnWhere (AR { T18791.hs:2:15-19 }))] + (AnnList + (Nothing) + (Nothing) + (Nothing) + [] + [])) + (AnnCommentsBalanced + [] + [(L + (Anchor + { T18791.hs:6:1 } + (UnchangedAnchor)) + (AnnComment + (AnnEofComment) + { T18791.hs:6:1 }))])) (VirtualBraces (1)) (Just - ({ T18791.hs:2:8-13 } + (L + { T18791.hs:2:8-13 } {ModuleName: T18791})) (Nothing) [] - [({ T18791.hs:(4,1)-(5,17) } + [(L + (SrcSpanAnn (ApiAnn + (Anchor + { T18791.hs:(4,1)-(5,17) } + (UnchangedAnchor)) + (AnnListItem + []) + (AnnComments + [])) { T18791.hs:(4,1)-(5,17) }) (TyClD (NoExtField) (DataDecl - (NoExtField) - ({ T18791.hs:4:6 } + (ApiAnn + (Anchor + { T18791.hs:(4,1)-(5,17) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T18791.hs:4:1-4 })) + ,(AddApiAnn AnnWhere (AR { T18791.hs:4:8-12 }))] + (AnnComments + [])) + (L + (SrcSpanAnn (ApiAnnNotUsed) { T18791.hs:4:6 }) (Unqual {OccName: T})) (HsQTvs @@ -23,18 +63,34 @@ []) (Prefix) (HsDataDefn - (NoExtField) + (ApiAnn + (Anchor + { T18791.hs:(4,1)-(5,17) } + (UnchangedAnchor)) + [(AddApiAnn AnnData (AR { T18791.hs:4:1-4 })) + ,(AddApiAnn AnnWhere (AR { T18791.hs:4:8-12 }))] + (AnnComments + [])) (DataType) (Nothing) (Nothing) (Nothing) - [({ T18791.hs:5:3-17 } + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T18791.hs:5:3-17 }) (ConDeclGADT - (NoExtField) - [({ T18791.hs:5:3-5 } + (ApiAnn + (Anchor + { T18791.hs:5:3-17 } + (UnchangedAnchor)) + [(AddApiAnn AnnDcolon (AR { T18791.hs:5:7-8 }))] + (AnnComments + [])) + [(L + (SrcSpanAnn (ApiAnnNotUsed) { T18791.hs:5:3-5 }) (Unqual {OccName: MkT}))] - ({ T18791.hs:5:10-17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T18791.hs:5:10-17 }) (HsOuterImplicit (NoExtField))) (Nothing) @@ -42,24 +98,45 @@ [(HsScaled (HsUnrestrictedArrow (NormalSyntax)) - ({ T18791.hs:5:10-12 } + (L + (SrcSpanAnn (ApiAnn + (Anchor + { T18791.hs:5:10-12 } + (UnchangedAnchor)) + (AnnListItem + [(AddRarrowAnn + (AR { T18791.hs:5:14-15 }))]) + (AnnComments + [])) { T18791.hs:5:10-12 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T18791.hs:5:10-12 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T18791.hs:5:10-12 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T18791.hs:5:10-12 }) (Unqual {OccName: Int})))))]) - ({ T18791.hs:5:17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T18791.hs:5:17 }) (HsTyVar - (NoExtField) + (ApiAnn + (Anchor + { T18791.hs:5:17 } + (UnchangedAnchor)) + [] + (AnnComments + [])) (NotPromoted) - ({ T18791.hs:5:17 } + (L + (SrcSpanAnn (ApiAnnNotUsed) { T18791.hs:5:17 }) (Unqual {OccName: T})))) (Nothing)))] - ({ <no location info> } - [])))))] + []))))] (Nothing) (Nothing))) - - diff --git a/testsuite/tests/ghc-api/annotations/Test10255.hs b/testsuite/tests/printer/Test10255.hs index 2cfc53bbfb..2cfc53bbfb 100644 --- a/testsuite/tests/ghc-api/annotations/Test10255.hs +++ b/testsuite/tests/printer/Test10255.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10268.hs b/testsuite/tests/printer/Test10268.hs index 04cc0e7e0e..04cc0e7e0e 100644 --- a/testsuite/tests/ghc-api/annotations/Test10268.hs +++ b/testsuite/tests/printer/Test10268.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10269.hs b/testsuite/tests/printer/Test10269.hs index c6df750c04..c6df750c04 100644 --- a/testsuite/tests/ghc-api/annotations/Test10269.hs +++ b/testsuite/tests/printer/Test10269.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10276.hs b/testsuite/tests/printer/Test10276.hs index dcf2549979..dcf2549979 100644 --- a/testsuite/tests/ghc-api/annotations/Test10276.hs +++ b/testsuite/tests/printer/Test10276.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10278.hs b/testsuite/tests/printer/Test10278.hs index d9b14f65c1..d9b14f65c1 100644 --- a/testsuite/tests/ghc-api/annotations/Test10278.hs +++ b/testsuite/tests/printer/Test10278.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10280.hs b/testsuite/tests/printer/Test10280.hs index 08e4186715..08e4186715 100644 --- a/testsuite/tests/ghc-api/annotations/Test10280.hs +++ b/testsuite/tests/printer/Test10280.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10307.hs b/testsuite/tests/printer/Test10307.hs index 938801a8d6..938801a8d6 100644 --- a/testsuite/tests/ghc-api/annotations/Test10307.hs +++ b/testsuite/tests/printer/Test10307.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10309.hs b/testsuite/tests/printer/Test10309.hs index 75f18a9b71..75f18a9b71 100644 --- a/testsuite/tests/ghc-api/annotations/Test10309.hs +++ b/testsuite/tests/printer/Test10309.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10312.hs b/testsuite/tests/printer/Test10312.hs index 6d3c8476e9..6d3c8476e9 100644 --- a/testsuite/tests/ghc-api/annotations/Test10312.hs +++ b/testsuite/tests/printer/Test10312.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10313.hs b/testsuite/tests/printer/Test10313.hs index a94c9eac91..a94c9eac91 100644 --- a/testsuite/tests/ghc-api/annotations/Test10313.hs +++ b/testsuite/tests/printer/Test10313.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10354.hs b/testsuite/tests/printer/Test10354.hs index 267ea45ab0..267ea45ab0 100644 --- a/testsuite/tests/ghc-api/annotations/Test10354.hs +++ b/testsuite/tests/printer/Test10354.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10357.hs b/testsuite/tests/printer/Test10357.hs index 8790ca6c1b..8790ca6c1b 100644 --- a/testsuite/tests/ghc-api/annotations/Test10357.hs +++ b/testsuite/tests/printer/Test10357.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10358.hs b/testsuite/tests/printer/Test10358.hs index 1e1ce35690..1e1ce35690 100644 --- a/testsuite/tests/ghc-api/annotations/Test10358.hs +++ b/testsuite/tests/printer/Test10358.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10396.hs b/testsuite/tests/printer/Test10396.hs index 71b18a8f9e..71b18a8f9e 100644 --- a/testsuite/tests/ghc-api/annotations/Test10396.hs +++ b/testsuite/tests/printer/Test10396.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10399.hs b/testsuite/tests/printer/Test10399.hs index bb3265000d..bb3265000d 100644 --- a/testsuite/tests/ghc-api/annotations/Test10399.hs +++ b/testsuite/tests/printer/Test10399.hs diff --git a/testsuite/tests/ghc-api/annotations/Test10598.hs b/testsuite/tests/printer/Test10598.hs index 8a7651c154..8a7651c154 100644 --- a/testsuite/tests/ghc-api/annotations/Test10598.hs +++ b/testsuite/tests/printer/Test10598.hs diff --git a/testsuite/tests/ghc-api/annotations/Test11018.hs b/testsuite/tests/printer/Test11018.hs index e1d020540e..e1d020540e 100644 --- a/testsuite/tests/ghc-api/annotations/Test11018.hs +++ b/testsuite/tests/printer/Test11018.hs diff --git a/testsuite/tests/ghc-api/annotations/Test11321.hs b/testsuite/tests/printer/Test11321.hs index d88d997077..d88d997077 100644 --- a/testsuite/tests/ghc-api/annotations/Test11321.hs +++ b/testsuite/tests/printer/Test11321.hs diff --git a/testsuite/tests/ghc-api/annotations/Test11332.hs b/testsuite/tests/printer/Test11332.hs index 41e84b0d39..41e84b0d39 100644 --- a/testsuite/tests/ghc-api/annotations/Test11332.hs +++ b/testsuite/tests/printer/Test11332.hs diff --git a/testsuite/tests/ghc-api/annotations/Test11430.hs b/testsuite/tests/printer/Test11430.hs index 19b8e54ccd..19b8e54ccd 100644 --- a/testsuite/tests/ghc-api/annotations/Test11430.hs +++ b/testsuite/tests/printer/Test11430.hs diff --git a/testsuite/tests/ghc-api/annotations/Test12417.hs b/testsuite/tests/printer/Test12417.hs index 67da7f2107..67da7f2107 100644 --- a/testsuite/tests/ghc-api/annotations/Test12417.hs +++ b/testsuite/tests/printer/Test12417.hs diff --git a/testsuite/tests/ghc-api/annotations/Test13163.hs b/testsuite/tests/printer/Test13163.hs index 439d825386..439d825386 100644 --- a/testsuite/tests/ghc-api/annotations/Test13163.hs +++ b/testsuite/tests/printer/Test13163.hs diff --git a/testsuite/tests/printer/Test15242.hs b/testsuite/tests/printer/Test15242.hs new file mode 100644 index 0000000000..1970e488fd --- /dev/null +++ b/testsuite/tests/printer/Test15242.hs @@ -0,0 +1,4 @@ +module Test15242 where + +f = (((const) 3)) ((((seq) 'a')) 'b') +g = ((((((((((id id)) id) id) id))) id))) id diff --git a/testsuite/tests/ghc-api/annotations/Test15303.hs b/testsuite/tests/printer/Test15303.hs index 212e9da5ac..212e9da5ac 100644 --- a/testsuite/tests/ghc-api/annotations/Test15303.hs +++ b/testsuite/tests/printer/Test15303.hs diff --git a/testsuite/tests/ghc-api/annotations/Test16212.hs b/testsuite/tests/printer/Test16212.hs index da7e322307..da7e322307 100644 --- a/testsuite/tests/ghc-api/annotations/Test16212.hs +++ b/testsuite/tests/printer/Test16212.hs diff --git a/testsuite/tests/ghc-api/annotations/Test16230.hs b/testsuite/tests/printer/Test16230.hs index e231878464..8cccc1de45 100644 --- a/testsuite/tests/ghc-api/annotations/Test16230.hs +++ b/testsuite/tests/printer/Test16230.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DatatypeContexts, ExistentialQuantification #-} module MoreExplicitForalls where import Data.Proxy @@ -21,3 +22,13 @@ instance forall a. C [a] where type family G a b where forall x y. G [x] (Proxy y) = Double forall z. G z z = Bool + + +data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) +data instance forall a (b :: Proxy a). F (Proxy b) = FProxy Bool +data instance forall k (a :: k). F a = FOtherwise -- accepted + +data family D a b +data instance (Show b) => D Int b +data instance forall b . (Show b) => D Int b +data instance forall b . D Int b diff --git a/testsuite/tests/ghc-api/annotations/Test16236.hs b/testsuite/tests/printer/Test16236.hs index e19a0ee0c1..e19a0ee0c1 100644 --- a/testsuite/tests/ghc-api/annotations/Test16236.hs +++ b/testsuite/tests/printer/Test16236.hs diff --git a/testsuite/tests/ghc-api/annotations/Test16279.hs b/testsuite/tests/printer/Test16279.hs index 7817edadc5..7817edadc5 100644 --- a/testsuite/tests/ghc-api/annotations/Test16279.hs +++ b/testsuite/tests/printer/Test16279.hs diff --git a/testsuite/tests/ghc-api/annotations/Test17388.hs b/testsuite/tests/printer/Test17388.hs index d5ead3d95e..d5ead3d95e 100644 --- a/testsuite/tests/ghc-api/annotations/Test17388.hs +++ b/testsuite/tests/printer/Test17388.hs diff --git a/testsuite/tests/ghc-api/annotations/Test17519.hs b/testsuite/tests/printer/Test17519.hs index f705008c51..f705008c51 100644 --- a/testsuite/tests/ghc-api/annotations/Test17519.hs +++ b/testsuite/tests/printer/Test17519.hs diff --git a/testsuite/tests/ghc-api/annotations/TestBoolFormula.hs b/testsuite/tests/printer/TestBoolFormula.hs index e76ce40fe5..e76ce40fe5 100644 --- a/testsuite/tests/ghc-api/annotations/TestBoolFormula.hs +++ b/testsuite/tests/printer/TestBoolFormula.hs diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index 2c605be5b8..d4cd67c3dd 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -1,13 +1,18 @@ test('Ppr001', ignore_stderr, makefile_test, ['ppr001']) test('Ppr002', ignore_stderr, makefile_test, ['ppr002']) +test('Ppr002a', ignore_stderr, makefile_test, ['ppr002a']) test('Ppr003', ignore_stderr, makefile_test, ['ppr003']) test('Ppr004', ignore_stderr, makefile_test, ['ppr004']) test('Ppr005', ignore_stderr, makefile_test, ['ppr005']) test('Ppr006', ignore_stderr, makefile_test, ['ppr006']) test('Ppr007', ignore_stderr, makefile_test, ['ppr007']) -test('Ppr008', ignore_stderr, makefile_test, ['ppr008']) + +# These tests have CPP, and as of 2021-03-15 the processing on the +# darwin and windows platforms is slightly different. +#test('Ppr008', [ignore_stderr,expect_fail], makefile_test, ['ppr008']) +#test('Ppr010', [ignore_stderr,expect_fail], makefile_test, ['ppr010']) + test('Ppr009', ignore_stderr, makefile_test, ['ppr009']) -test('Ppr010', ignore_stderr, makefile_test, ['ppr010']) test('Ppr011', ignore_stderr, makefile_test, ['ppr011']) test('Ppr012', ignore_stderr, makefile_test, ['ppr012']) test('Ppr013', ignore_stderr, makefile_test, ['ppr013']) @@ -45,6 +50,13 @@ test('Ppr044', ignore_stderr, makefile_test, ['ppr044']) test('Ppr045', ignore_stderr, makefile_test, ['ppr045']) test('Ppr046', ignore_stderr, makefile_test, ['ppr046']) test('Ppr048', ignore_stderr, makefile_test, ['ppr048']) +test('Ppr049', ignore_stderr, makefile_test, ['ppr049']) +test('Ppr050', ignore_stderr, makefile_test, ['ppr050']) +test('Ppr051', ignore_stderr, makefile_test, ['ppr051']) +test('Ppr052', ignore_stderr, makefile_test, ['ppr052']) +test('Ppr053', ignore_stderr, makefile_test, ['ppr053']) +test('Ppr054', ignore_stderr, makefile_test, ['ppr054']) +test('Ppr055', ignore_stderr, makefile_test, ['ppr055']) test('T13199', [ignore_stderr, req_interp], makefile_test, ['T13199']) test('T13050p', ignore_stderr, makefile_test, ['T13050p']) test('T13550', [ignore_stderr, req_interp], makefile_test, ['T13550']) @@ -59,3 +71,53 @@ test('T15761', normal, compile_fail, ['']) test('T18052a', normal, compile, ['-ddump-simpl -ddump-types -dno-typeable-binds -dsuppress-uniques']) test('T18791', normal, compile, ['-ddump-parsed-ast']) +test('RdrNames', ignore_stderr, makefile_test, ['RdrNames']) +test('StarBinderAnns', ignore_stderr, makefile_test, ['StarBinderAnns']) +test('Test10255', ignore_stderr, makefile_test, ['Test10255']) +test('Test10268', ignore_stderr, makefile_test, ['Test10268']) +test('Test10269', ignore_stderr, makefile_test, ['Test10269']) +test('Test10276', ignore_stderr, makefile_test, ['Test10276']) +test('Test10278', ignore_stderr, makefile_test, ['Test10278']) +test('Test10280', ignore_stderr, makefile_test, ['Test10280']) +test('Test10307', ignore_stderr, makefile_test, ['Test10307']) +test('Test10309', ignore_stderr, makefile_test, ['Test10309']) +test('Test10312', ignore_stderr, makefile_test, ['Test10312']) +test('Test10313', ignore_stderr, makefile_test, ['Test10313']) +test('Test10354', ignore_stderr, makefile_test, ['Test10354']) +test('Test10357', ignore_stderr, makefile_test, ['Test10357']) +test('Test10358', ignore_stderr, makefile_test, ['Test10358']) +test('Test10396', ignore_stderr, makefile_test, ['Test10396']) +test('Test10399', ignore_stderr, makefile_test, ['Test10399']) +test('Test10598', ignore_stderr, makefile_test, ['Test10598']) + +# PPR of unicode -> does not roundtrip. See #18846 +test('Test11018', [ignore_stderr,expect_fail], makefile_test, ['Test11018']) +test('Test17519', [ignore_stderr,expect_fail], makefile_test, ['Test17519']) + +test('Test11321', ignore_stderr, makefile_test, ['Test11321']) +test('Test11332', ignore_stderr, makefile_test, ['Test11332']) + +test('Test11430', ignore_stderr, makefile_test, ['Test11430']) +test('Test12417', ignore_stderr, makefile_test, ['Test12417']) +test('Test13163', ignore_stderr, makefile_test, ['Test13163']) +test('Test15303', ignore_stderr, makefile_test, ['Test15303']) +test('Test16212', ignore_stderr, makefile_test, ['Test16212']) +test('Test16230', ignore_stderr, makefile_test, ['Test16230']) +test('Test16236', ignore_stderr, makefile_test, ['Test16236']) +test('Test16279', ignore_stderr, makefile_test, ['Test16279']) +test('Test17388', ignore_stderr, makefile_test, ['Test17388']) +test('Test15242', ignore_stderr, makefile_test, ['Test15242']) +test('AnnotationLet', ignore_stderr, makefile_test, ['AnnotationLet']) +test('TestBoolFormula', ignore_stderr, makefile_test, ['TestBoolFormula']) +test('BundleExport', ignore_stderr, makefile_test, ['BundleExport']) +test('AnnotationTuple', ignore_stderr, makefile_test, ['AnnotationTuple']) +test('ListComprehensions', ignore_stderr, makefile_test, ['ListComprehensions']) +test('load-main', ignore_stderr, makefile_test, ['load-main']) + +# PPR of explicit foralls needs the "." to have an extra space. See note in pprHsForAll +test('PprRecordDotSyntax1', [ignore_stderr, expect_fail], makefile_test, ['PprRecordDotSyntax1']) + +test('PprRecordDotSyntax2', ignore_stderr, makefile_test, ['PprRecordDotSyntax2']) +test('PprRecordDotSyntax3', ignore_stderr, makefile_test, ['PprRecordDotSyntax3']) +test('PprRecordDotSyntax4', ignore_stderr, makefile_test, ['PprRecordDotSyntax4']) +test('PprRecordDotSyntaxA', ignore_stderr, makefile_test, ['PprRecordDotSyntaxA']) diff --git a/testsuite/tests/ghc-api/annotations/load-main.hs b/testsuite/tests/printer/load-main.hs index 4628a423b8..4628a423b8 100644 --- a/testsuite/tests/ghc-api/annotations/load-main.hs +++ b/testsuite/tests/printer/load-main.hs diff --git a/testsuite/tests/th/T10603.stderr b/testsuite/tests/th/T10603.stderr index 3de6cb057b..2828bb078a 100644 --- a/testsuite/tests/th/T10603.stderr +++ b/testsuite/tests/th/T10603.stderr @@ -1,4 +1,4 @@ T10603.hs:5:17-69: Splicing expression - [| case Just 'a' of { Just a -> Just ((\ x -> x) a) } |] + [| case Just 'a' of Just a -> Just ((\ x -> x) a) |] ======> - case Just 'a' of { Just a -> Just ((\ x -> x) a) } + case Just 'a' of Just a -> Just ((\ x -> x) a) diff --git a/testsuite/tests/th/TH_StaticPointers02.stderr b/testsuite/tests/th/TH_StaticPointers02.stderr index a89ad11b0d..6d2c759ab8 100644 --- a/testsuite/tests/th/TH_StaticPointers02.stderr +++ b/testsuite/tests/th/TH_StaticPointers02.stderr @@ -2,11 +2,11 @@ TH_StaticPointers02.hs:11:34: error: • static forms cannot be used in splices: static 'a' • In the untyped splice: - $(case staticKey (static 'a') of { + $(case staticKey (static 'a') of Fingerprint w0 w1 -> let w0i = ... w1i = ... in [| fmap (\ p -> deRefStaticPtr p :: Char) $ unsafeLookupStaticPtr - $ Fingerprint (fromIntegral w0i) (fromIntegral w1i) |] }) + $ Fingerprint (fromIntegral w0i) (fromIntegral w1i) |]) diff --git a/testsuite/tests/th/TH_exn1.stderr b/testsuite/tests/th/TH_exn1.stderr index 69c854e244..2df704662c 100644 --- a/testsuite/tests/th/TH_exn1.stderr +++ b/testsuite/tests/th/TH_exn1.stderr @@ -3,4 +3,4 @@ TH_exn1.hs:1:1: error: Exception when trying to run compile-time code: TH_exn1.hs:(9,4)-(10,23): Non-exhaustive patterns in case - Code: (case reverse "no" of { [] -> return [] }) + Code: (case reverse "no" of [] -> return []) diff --git a/testsuite/tests/typecheck/should_compile/T12427a.stderr b/testsuite/tests/typecheck/should_compile/T12427a.stderr index b9c3969bf0..84f330e717 100644 --- a/testsuite/tests/typecheck/should_compile/T12427a.stderr +++ b/testsuite/tests/typecheck/should_compile/T12427a.stderr @@ -7,7 +7,7 @@ T12427a.hs:17:29: error: at T12427a.hs:17:1-29 • In the expression: v In a case alternative: T1 _ v -> v - In the expression: case y of { T1 _ v -> v } + In the expression: case y of T1 _ v -> v • Relevant bindings include h11 :: T -> p (bound at T12427a.hs:17:1) diff --git a/testsuite/tests/typecheck/should_compile/T15242.stderr b/testsuite/tests/typecheck/should_compile/T15242.stderr index 0435a644f8..6b75097d69 100644 --- a/testsuite/tests/typecheck/should_compile/T15242.stderr +++ b/testsuite/tests/typecheck/should_compile/T15242.stderr @@ -1,34 +1,34 @@ -({ T15242.hs:6:5-41 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:5-41 }) (HsPar -({ T15242.hs:6:6-40 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:6-40 }) (HsPar -({ T15242.hs:6:7-39 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:7-39 }) (HsPar -({ T15242.hs:6:8-35 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:8-35 }) (HsPar -({ T15242.hs:6:9-34 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:9-34 }) (HsPar -({ T15242.hs:6:10-33 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:10-33 }) (HsPar -({ T15242.hs:6:11-29 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:11-29 }) (HsPar -({ T15242.hs:6:12-25 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:12-25 }) (HsPar -({ T15242.hs:6:13-21 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:13-21 }) (HsPar -({ T15242.hs:6:14-20 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:6:14-20 }) (HsPar -({ T15242.hs:5:5-17 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:5:5-17 }) (HsPar -({ T15242.hs:5:6-16 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:5:6-16 }) (HsPar -({ T15242.hs:5:7-13 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:5:7-13 }) (HsPar -({ T15242.hs:5:19-37 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:5:19-37 }) (HsPar -({ T15242.hs:5:20-32 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:5:20-32 }) (HsPar -({ T15242.hs:5:21-31 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:5:21-31 }) (HsPar -({ T15242.hs:5:22-26 } +(SrcSpanAnn (ApiAnnNotUsed) { T15242.hs:5:22-26 }) (HsPar diff --git a/testsuite/tests/typecheck/should_compile/hole_constraints.stderr b/testsuite/tests/typecheck/should_compile/hole_constraints.stderr index 2e32b1b92a..28f3ad92ba 100644 --- a/testsuite/tests/typecheck/should_compile/hole_constraints.stderr +++ b/testsuite/tests/typecheck/should_compile/hole_constraints.stderr @@ -59,8 +59,8 @@ hole_constraints.hs:20:19: warning: [-Wtyped-holes (in -Wdefault)] hole_constraints.hs:27:32: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: String • In a case alternative: AnyShow x -> _ - In the expression: case a of { AnyShow x -> _ } - In an equation for ‘foo’: foo a = case a of { AnyShow x -> _ } + In the expression: case a of AnyShow x -> _ + In an equation for ‘foo’: foo a = case a of AnyShow x -> _ • Relevant bindings include x :: a (bound at hole_constraints.hs:27:27) a :: AnyShow (bound at hole_constraints.hs:27:5) diff --git a/testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr b/testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr index 6ca50b65b4..9667fc3a89 100644 --- a/testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr +++ b/testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr @@ -2,8 +2,8 @@ hole_constraints_nested.hs:12:16: warning: [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int • In a case alternative: EqOrd -> _ - In the expression: case d2 of { EqOrd -> _ } - In a case alternative: Refl -> case d2 of { EqOrd -> _ } + In the expression: case d2 of EqOrd -> _ + In a case alternative: Refl -> case d2 of EqOrd -> _ • Relevant bindings include d2 :: EqOrd a (bound at hole_constraints_nested.hs:9:6) d1 :: a :~: b (bound at hole_constraints_nested.hs:9:3) diff --git a/testsuite/tests/typecheck/should_fail/tcfail069.stderr b/testsuite/tests/typecheck/should_fail/tcfail069.stderr index a7c996ce84..592265adb8 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail069.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail069.stderr @@ -4,4 +4,4 @@ tcfail069.hs:21:7: error: with actual type: [a0] • In the pattern: [] In a case alternative: [] -> error "foo" - In the expression: case (list1, list2) of { [] -> error "foo" } + In the expression: case (list1, list2) of [] -> error "foo" diff --git a/testsuite/tests/typecheck/should_fail/tcfail159.stderr b/testsuite/tests/typecheck/should_fail/tcfail159.stderr index 706b3afa32..5a49966637 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail159.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail159.stderr @@ -3,4 +3,4 @@ tcfail159.hs:9:11: error: • Expecting a lifted type, but got an unlifted type • In the pattern: ~(# p, q #) In a case alternative: ~(# p, q #) -> p - In the expression: case h x of { ~(# p, q #) -> p } + In the expression: case h x of ~(# p, q #) -> p diff --git a/testsuite/tests/typecheck/should_fail/tcfail180.stderr b/testsuite/tests/typecheck/should_fail/tcfail180.stderr index 7764b7798b..da7725fdb0 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail180.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail180.stderr @@ -3,4 +3,4 @@ tcfail180.hs:10:9: Couldn't match expected type ‘f0 b0’ with actual type ‘Bool’ In the pattern: True In a case alternative: True -> () - In the expression: case p of { True -> () } + In the expression: case p of True -> () diff --git a/testsuite/tests/unboxedsums/Makefile b/testsuite/tests/unboxedsums/Makefile deleted file mode 100644 index ff17bccc51..0000000000 --- a/testsuite/tests/unboxedsums/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -TOP=../.. -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk - -.PHONY: sum_api_annots -sum_api_annots: - number=1 ; while [[ $$number -le 11 ]] ; do \ - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" unboxedsums$$number.hs ; \ - ((number = number + 1)) ; \ - done diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T index 764a850aec..c697a42886 100644 --- a/testsuite/tests/unboxedsums/all.T +++ b/testsuite/tests/unboxedsums/all.T @@ -24,11 +24,5 @@ test('empty_sum', only_ways(['normal']), compile_and_run, ['']) test('sum_rr', normal, compile, ['']) test('T12711', only_ways(['ghci']), ghci_script, ['T12711.script']) -# TODO: Need to run this in --slow mode only -# test('sum_api_annots', -# [only_ways(['normal']), -# extra_files([ "unboxedsums" + str(i) + ".hs" for i in range(1, 12) ])], -# makefile_test, []) - test('UbxSumLevPoly', normal, compile, ['-Wno-overlapping-patterns']) test('T14051', normal, multi_compile, ['T14051.hs', [('T14051a.hs', '')], '-O2 -v0']) diff --git a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr index a4b6cc0b74..3f0a4f350b 100644 --- a/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr +++ b/testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr @@ -30,7 +30,7 @@ CaretDiagnostics1.hs:13:7-11: error: Actual: String • In the pattern: "γηξ" In a case alternative: "γηξ" -> () '0' - In the expression: case id of { "γηξ" -> () '0' } + In the expression: case id of "γηξ" -> () '0' | 13 | "γηξ" -> ( | ^^^^^ diff --git a/utils/check-api-annotations/Main.hs b/utils/check-api-annotations/Main.hs deleted file mode 100644 index 7fd6180182..0000000000 --- a/utils/check-api-annotations/Main.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -import Data.Data -import Data.List -import GHC -import GHC.Driver.Ppr -import GHC.Utils.Outputable -import GHC.Types.SrcLoc -import System.Environment( getArgs ) -import System.Exit -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Maybe( isJust ) - -main::IO() -main = do - args <- getArgs - case args of - [libdir,fileName] -> testOneFile libdir fileName - _ -> putStrLn "invoke with the libdir and a file to parse." - -testOneFile :: FilePath -> String -> IO () -testOneFile libdir fileName = do - let modByFile m = - case ml_hs_file $ ms_location m of - Nothing -> False - Just fn -> fn == fileName - (anns,p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - _ <- setSessionDynFlags dflags - addTarget Target { targetId = TargetFile fileName Nothing - , targetAllowObjCode = True - , targetContents = Nothing } - _ <- load LoadAllTargets - graph <- getModuleGraph - let modSum = - case filter modByFile (mgModSummaries graph) of - [x] -> x - xs -> error $ "Can't find module, got:" - ++ show (map (ml_hs_file . ms_location) xs) - p <- parseModule modSum - return (pm_annotations p,p) - - let sspans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) - - ann_items = apiAnnItems anns - - exploded = [((kw,ss),[anchor]) - | ((anchor,kw),sss) <- Map.toList ann_items,ss <- sss] - - exploded' = Map.toList $ Map.fromListWith (++) exploded - - problems' = filter (\(_,anchors) - -> not (any (\a -> Set.member a sspans) anchors)) - exploded' - - -- Check that every annotation location in 'vs' appears after - -- the start of the enclosing span 's' - comesBefore ((s,_),vs) = not $ all ok vs - where ok v = realSrcSpanStart s <= realSrcSpanStart v - - precedingProblems = filter comesBefore $ Map.toList ann_items - - putStrLn "---Unattached Annotation Problems (should be empty list)---" - putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems']) - putStrLn "---Ann before enclosing span problem (should be empty list)---" - putStrLn (showAnnsList precedingProblems) - putStrLn "---Annotations-----------------------" - putStrLn "-- SrcSpan the annotation is attached to, AnnKeywordId," - putStrLn "-- list of locations the keyword item appears in" - -- putStrLn (intercalate "\n" [showAnns ann_items]) - putStrLn (showAnns ann_items) - putStrLn "---Eof Position (should be Just)-----" - putStrLn (show (apiAnnEofPos anns)) - if null problems' && null precedingProblems && isJust (apiAnnEofPos anns) - then exitSuccess - else exitFailure - - where - getAllSrcSpans :: (Data t) => t -> [RealSrcSpan] - getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [RealSrcSpan] - getSrcSpan (RealSrcSpan ss _) = [ss] - getSrcSpan (UnhelpfulSpan _) = [] - - -showAnns :: Map.Map ApiAnnKey [RealSrcSpan] -> String -showAnns anns = showAnnsList $ Map.toList anns - -showAnnsList :: [(ApiAnnKey, [RealSrcSpan])] -> String -showAnnsList annsList = "[\n" ++ (intercalate ",\n" - $ map (\((s,k),v) - -> ("((" ++ pp s ++ "," ++ show k ++"), " ++ pp v ++ ")")) - annsList) - ++ "\n]\n" - -pp :: (Outputable a) => a -> String -pp a = showPprUnsafe a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/utils/check-api-annotations/README b/utils/check-api-annotations/README deleted file mode 100644 index 5d852a30bf..0000000000 --- a/utils/check-api-annotations/README +++ /dev/null @@ -1,103 +0,0 @@ -This programme is intended to be used by any GHC developers working on GHC.Parser -or GHC.Parser.PostProcess, and who want to check that their changes do not break the API -Annotations. - -It does a basic test that all annotations do make it to the final AST, and dumps -a list of the annotations generated for a given file, so that they can be -checked against the source being parsed for sanity. - -This utility is also intended to be used in tests, so that when new features are -added the expected annotations are also captured. - -Usage - -In a test Makefile - - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" FileToParse.hs - -See examples in (REPO_HOME)/testsuite/tests/ghc-api/annotations/Makefile - - -Description of operation ------------------------- - -The programme is called with the name of a haskell source file. - -It uses the GHC API to load and parse this, and extracts the API annotations. - -These are of the form - - Map.Map ApiAnnKey [SrcSpan] - -where - - type ApiAnnKey = (SrcSpan,AnnKeywordId) - -So an annotation is a key comprising the parent SrcSpan in the ParsedSource -together with an AnnKeywordId, and this maps to a list of locations where the -specific keyword item occurs in the original source. - -The utility extracts all SrcSpans in the ParsedSource, and makes sure that for -every ApiAnnKey the SrcSpan is actually present in the final ParsedSource. This -is to ensure that when a given parser production is postprocessed anywhere along -the line the relevant SrcSpan is not discarded, thus detaching the annotation -from the final output. - -It also provides a list of each ApiAnnKey and the corresponding source -locations, so these can be checked against the original source for correctness. - -Example -------- - -Test10255.hs in the ghc-api/annotations tests has the following source - ------------------------------- -1:{-# LANGUAGE ScopedTypeVariables #-} -2:module Test10255 where -3: -4:import Data.Maybe -5: -6:fob (f :: (Maybe t -> Int)) = -7: undefined ------------------------------- - -The output of this utility is - ------------------------------------------------------------------------- ----Problems (should be empty list)--- -[] ----Annotations----------------------- --- SrcSpan the annotation is attached to, AnnKeywordId, --- list of locations the keyword item appears in -[ -((Test10255.hs:1:1,AnnModule), [Test10255.hs:2:1-6]), -((Test10255.hs:1:1,AnnWhere), [Test10255.hs:2:18-22]), -((Test10255.hs:4:1-17,AnnImport), [Test10255.hs:4:1-6]), -((Test10255.hs:4:1-17,AnnSemi), [Test10255.hs:6:1]), -((Test10255.hs:(6,1)-(7,11),AnnEqual), [Test10255.hs:6:29]), -((Test10255.hs:(6,1)-(7,11),AnnFunId), [Test10255.hs:6:1-3]), -((Test10255.hs:(6,1)-(7,11),AnnSemi), [Test10255.hs:8:1]), -((Test10255.hs:6:5-27,AnnCloseP), [Test10255.hs:6:27]), -((Test10255.hs:6:5-27,AnnOpenP), [Test10255.hs:6:5]), -((Test10255.hs:6:6-26,AnnDcolon), [Test10255.hs:6:8-9]), -((Test10255.hs:6:11-26,AnnCloseP), [Test10255.hs:6:26]), -((Test10255.hs:6:11-26,AnnOpenP), [Test10255.hs:6:11]), -((Test10255.hs:6:12-18,AnnRarrow), [Test10255.hs:6:20-21]), -((Test10255.hs:6:12-25,AnnRarrow), [Test10255.hs:6:20-21]), -((<no location info>,AnnEofPos), [Test10255.hs:8:1]) -] ------------------------------------------------------------------------- - -To interpret this, firstly the problems list is empty, so there are not -annotations that do not appear in the final AST. - -Secondly, the list of annotations and locations can be checked against the test -source code to ensure that every AnnKeywordId does in fact appear. - -It will return a zero exit code if the list of problems is empty, non-zero -otherwise. - -Note: In some cases, such as T10269 in the ghc-api/annotations tests the list is -non-empty, due to postprocessing of the parsed result. In general this should -only happen for an `AnnVal` and if it does the actual annotations provided need -to be inspected to check that an equivalent annotation is provided. diff --git a/utils/check-api-annotations/check-api-annotations.cabal b/utils/check-api-annotations/check-api-annotations.cabal deleted file mode 100644 index dbaa25fd48..0000000000 --- a/utils/check-api-annotations/check-api-annotations.cabal +++ /dev/null @@ -1,29 +0,0 @@ -Name: check-api-annotations -Version: 0.1 -Copyright: XXX -License: BSD3 --- XXX License-File: LICENSE -Author: XXX -Maintainer: XXX -Synopsis: A utilities for checking the consistency of GHC's API annotations. -Description: - This utility is used to check the consistency between GHC's syntax tree - and API annotations used to track token-level details of the original - source file. See @utils/check-api-annotations/README@ in GHC's source - distribution for details. -Category: Development -build-type: Simple -cabal-version: >=1.10 - -Executable check-api-annotations - Default-Language: Haskell2010 - - Main-Is: Main.hs - - Ghc-Options: -Wall - - Build-Depends: base >= 4 && < 5, - containers, - Cabal >= 3.2 && < 3.6, - directory, - ghc diff --git a/utils/check-exact/.ghci b/utils/check-exact/.ghci new file mode 100644 index 0000000000..43ff67a50e --- /dev/null +++ b/utils/check-exact/.ghci @@ -0,0 +1,3 @@ +:set -package ghc +:set -i./src +:set -Wall diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs new file mode 100644 index 0000000000..8f4f89e265 --- /dev/null +++ b/utils/check-exact/ExactPrint.hs @@ -0,0 +1,4165 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module ExactPrint + ( + ExactPrint(..) + , exactPrint + -- , exactPrintWithOptions + ) where + +import GHC +import GHC.Core.Coercion.Axiom (Role(..)) +import GHC.Data.Bag +import qualified GHC.Data.BooleanFormula as BF +import GHC.Data.FastString +import GHC.Types.Basic hiding (EP) +import GHC.Types.Fixity +import GHC.Types.ForeignCall +import GHC.Types.SourceText +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Driver.Ppr +import GHC.Unit.Module.Warnings +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Control.Monad.Identity +import Control.Monad.RWS +import Data.Data ( Data ) +import Data.Foldable +import Data.Typeable +import Data.List ( partition, sort, sortBy) +import Data.Maybe ( isJust ) + +import Data.Void + +import Lookup +import Utils +import Types + +-- import Debug.Trace + +-- --------------------------------------------------------------------- + +exactPrint :: ExactPrint ast => Located ast -> ApiAnns -> String +exactPrint ast anns = runIdentity (runEP anns stringOptions (markAnnotated ast)) + +type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a +type EPP a = EP String Identity a + +runEP :: ApiAnns -> PrintOptions Identity String + -> Annotated () -> Identity String +runEP anns epReader action = + fmap (output . snd) . + (\next -> execRWST next epReader (defaultEPState anns)) + . xx $ action + +xx :: Annotated () -> EP String Identity () +-- xx :: Annotated() -> RWST (PrintOptions m w) (EPWriter w) EPState m () +xx = id + +-- --------------------------------------------------------------------- + +defaultEPState :: ApiAnns -> EPState +defaultEPState as = EPState + { epPos = (1,1) + , epApiAnns = as + , dLHS = 1 + , pMarkLayout = False + , pLHS = 1 + , dMarkLayout = False + , dPriorEndPosition = (1,1) + , uAnchorSpan = badRealSrcSpan + , uExtraDP = Nothing + , epComments = rogueComments as + } + + +-- --------------------------------------------------------------------- +-- The EP monad and basic combinators + +-- | The R part of RWS. The environment. Updated via 'local' as we +-- enter a new AST element, having a different anchor point. +data PrintOptions m a = PrintOptions + { + epAnn :: !Annotation + , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a + , epTokenPrint :: String -> m a + , epWhitespacePrint :: String -> m a + , epRigidity :: Rigidity + , epContext :: !AstContextSet + } + +-- | Helper to create a 'PrintOptions' +printOptions :: + (forall ast . Data ast => GHC.Located ast -> a -> m a) + -> (String -> m a) + -> (String -> m a) + -> Rigidity + -> PrintOptions m a +printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions + { + epAnn = annNone + , epAstPrint = astPrint + , epWhitespacePrint = wsPrint + , epTokenPrint = tokenPrint + , epRigidity = rigidity + , epContext = defaultACS + } + +-- | Options which can be used to print as a normal String. +stringOptions :: PrintOptions Identity String +stringOptions = printOptions (\_ b -> return b) return return NormalLayout + +data EPWriter a = EPWriter + { output :: !a } + +instance Monoid w => Semigroup (EPWriter w) where + (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) + +instance Monoid w => Monoid (EPWriter w) where + mempty = EPWriter mempty + +data EPState = EPState + { epApiAnns :: !ApiAnns + + , uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST + -- reference frame, from + -- Annotation + , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a + -- list + + -- Print phase + , epPos :: !Pos -- ^ Current output position + , pMarkLayout :: !Bool + , pLHS :: !LayoutStartCol + + -- Delta phase + , dPriorEndPosition :: !Pos -- ^ End of Position reached + -- when processing the + -- preceding element + , dMarkLayout :: !Bool + , dLHS :: !LayoutStartCol + + -- Shared + , epComments :: ![Comment] + } + +-- --------------------------------------------------------------------- + +-- AZ:TODO: this can just be a function :: (ApiAnn' a) -> Entry +class HasEntry ast where + fromAnn :: ast -> Entry + +-- --------------------------------------------------------------------- + +-- type Annotated = FreeT AnnotationF Identity +type Annotated a = EP String Identity a + +-- --------------------------------------------------------------------- + +-- | Key entry point. Switches to an independent AST element with its +-- own annotation, calculating new offsets, etc +markAnnotated :: ExactPrint a => a -> Annotated () +markAnnotated a = enterAnn (getAnnotationEntry a) a + +data Entry = Entry Anchor ApiAnnComments + | NoEntryVal + +instance (HasEntry (ApiAnn' an)) => HasEntry (SrcSpanAnn' (ApiAnn' an)) where + fromAnn (SrcSpanAnn ApiAnnNotUsed ss) = Entry (spanAsAnchor ss) noCom + fromAnn (SrcSpanAnn an _) = fromAnn an + +instance HasEntry (ApiAnn' a) where + fromAnn (ApiAnn anchor _ cs) = Entry anchor cs + fromAnn ApiAnnNotUsed = NoEntryVal + +-- --------------------------------------------------------------------- + +astId :: (Typeable a) => a -> String +astId a = show (typeOf a) + +-- | "Enter" an annotation, by using the associated 'anchor' field as +-- the new reference point for calculating all DeltaPos positions. +-- +-- This is combination of the ghc=exactprint Delta.withAST and +-- Print.exactPC functions and effectively does the delta processing +-- immediately followed by the print processing. JIT ghc-exactprint. +enterAnn :: (ExactPrint a) => Entry -> a -> Annotated () +enterAnn NoEntryVal a = do + p <- getPosP + debugM $ "enterAnn:NO ANN:(p,a) =" ++ show (p, astId a) ++ " starting" + -- curAnchor <- getAnchorU + -- printComments curAnchor + exact a + debugM $ "enterAnn:NO ANN:p =" ++ show (p, astId a) ++ " done" +enterAnn (Entry anchor' cs) a = do + p <- getPosP + debugM $ "enterAnn:(p,a) =" ++ show (p, astId a) ++ " starting" + let curAnchor = anchor anchor' -- As a base for the current AST element + debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) + addCommentsA (priorComments cs) + printComments curAnchor + -- ------------------------- + case anchor_op anchor' of + MovedAnchor dp -> do + debugM $ "enterAnn: MovedAnchor:" ++ show dp + -- Set the original anchor as prior end, so the rest of this AST + -- fragment has a reference + -- BUT: this means the entry DP can be calculated incorrectly too, + -- for immediately nested items. + setPriorEndNoLayoutD (ss2pos curAnchor) + _ -> do + return () + -- ------------------------- + setAnchorU curAnchor + -- ------------------------------------------------------------------- + -- The first part corresponds to the delta phase, so should only use + -- delta phase variables + -- ----------------------------------- + -- Calculate offset required to get to the start of the SrcSPan + off <- gets dLHS + let spanStart = ss2pos curAnchor + priorEndAfterComments <- getPriorEndD + let edp' = adjustDeltaForOffset 0 + -- Use the propagated offset if one is set + -- Note that we need to use the new offset if it has + -- changed. + off (ss2delta priorEndAfterComments curAnchor) + debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) + let edp'' = case anchor_op anchor' of + MovedAnchor dp -> dp + _ -> edp' + -- --------------------------------------------- + -- let edp = edp'' + med <- getExtraDP + setExtraDP Nothing + let edp = case med of + Nothing -> edp'' + -- Just dp -> addDP dp edp'' + Just (Anchor _ (MovedAnchor dp)) -> dp + -- Replace original with desired one. Allows all + -- list entry values to be DP (1,0) + Just (Anchor r _) -> dp + where + dp = adjustDeltaForOffset 0 + off (ss2delta priorEndAfterComments r) + when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp) + -- --------------------------------------------- + -- Preparation complete, perform the action + when (priorEndAfterComments < spanStart) (do + debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart + modify (\s -> s { dPriorEndPosition = spanStart } )) + + debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor) + debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) + + -- end of delta phase processing + -- ------------------------------------------------------------------- + -- start of print phase processing + + let + st = annNone { annEntryDelta = edp } + withOffset st (advance edp >> exact a) + + when ((getFollowingComments cs) /= []) $ do + debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs) + mapM_ printOneComment (map tokComment $ getFollowingComments cs) + debugM $ "ending trailing comments" + +-- --------------------------------------------------------------------- + +addCommentsA :: [LAnnotationComment] -> EPP () +addCommentsA csNew = addComments (map tokComment csNew) + -- cs <- getUnallocatedComments + -- -- AZ:TODO: sortedlist? + -- putUnallocatedComments (sort $ (map tokComment csNew) ++ cs) + +addComments :: [Comment] -> EPP () +addComments csNew = do + debugM $ "addComments:" ++ show csNew + cs <- getUnallocatedComments + let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (anchor l1) (anchor l2) + -- AZ:TODO: sortedlist? + putUnallocatedComments (sortBy cmp $ csNew ++ cs) + +-- --------------------------------------------------------------------- + +-- |In order to interleave annotations into the stream, we turn them into +-- comments. +annotationsToComments :: [AddApiAnn] -> [AnnKeywordId] -> EPP () +annotationsToComments ans kws = do + let + getSpans _ [] = [] + getSpans k1 (AddApiAnn k2 ss:as) + | k1 == k2 = ss : getSpans k1 as + | otherwise = getSpans k1 as + doOne :: AnnKeywordId -> EPP [Comment] + doOne kw = do + let sps =getSpans kw ans + return $ map (mkKWComment kw ) sps + -- TODO:AZ make sure these are sorted/merged properly when the invariant for + -- allocateComments is re-established. + newComments <- mapM doOne kws + addComments (concat newComments) + + +-- --------------------------------------------------------------------- + +-- Temporary function to simply reproduce the "normal" pretty printer output +withPpr :: (Outputable a) => a -> Annotated () +withPpr a = do + ss <- getAnchorU + debugM $ "withPpr: ss=" ++ show ss + printStringAtKw' ss (showPprUnsafe a) + +-- --------------------------------------------------------------------- +-- Modeled on Outputable + +-- | An AST fragment with an annotation must be able to return the +-- requirements for nesting another one, captured in an 'Entry', and +-- to be able to use the rest of the exactprint machinery to print the +-- element. In the analogy to Outputable, 'exact' plays the role of +-- 'ppr'. +class (Typeable a) => ExactPrint a where + getAnnotationEntry :: a -> Entry + exact :: a -> Annotated () + +-- --------------------------------------------------------------------- + +-- | Bare Located elements are simply stripped off without further +-- processing. +instance (ExactPrint a) => ExactPrint (Located a) where + getAnnotationEntry (L l _) = Entry (spanAsAnchor l) noCom + exact (L _ a) = markAnnotated a + +instance (ExactPrint a) => ExactPrint (LocatedA a) where + getAnnotationEntry = entryFromLocatedA + exact (L la a) = do + debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) + markAnnotated a + markALocatedA (ann la) + +instance (ExactPrint a) => ExactPrint [a] where + getAnnotationEntry = const NoEntryVal + exact ls = mapM_ markAnnotated ls + +instance (ExactPrint a) => ExactPrint (Maybe a) where + getAnnotationEntry = const NoEntryVal + exact Nothing = return () + exact (Just a) = markAnnotated a + +-- --------------------------------------------------------------------- + +-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' +instance ExactPrint HsModule where + getAnnotationEntry hsmod = fromAnn (hsmodAnn hsmod) + + exact hsmod@(HsModule ApiAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod + exact (HsModule an _lo mmn mexports imports decls mdeprec mbDoc) = do + + markAnnotated mbDoc + + case mmn of + Nothing -> return () + Just (L ln mn) -> do + markApiAnn' an am_main AnnModule + -- debugM $ "HsModule name: (ss,ln)=" ++ show (ss2pos ss,ss2pos (realSrcSpan ln)) + -- printStringAtSs ln (moduleNameString mn) + markAnnotated (L ln mn) + + -- forM_ mdeprec markLocated + setLayoutTopLevelP $ markAnnotated mdeprec + + setLayoutTopLevelP $ markAnnotated mexports + + debugM $ "HsModule.AnnWhere coming" + setLayoutTopLevelP $ markApiAnn' an am_main AnnWhere + + setLayoutTopLevelP $ mapM_ markAddApiAnn (al_open $ am_decls $ anns an) + + -- markOptional GHC.AnnOpenC -- Possible '{' + -- markManyOptional GHC.AnnSemi -- possible leading semis + -- setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imports + -- markListWithLayout imports + markTopLevelList imports + + -- setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decls + -- markListWithLayout decls + -- setLayoutTopLevelP $ markAnnotated decls + markTopLevelList decls + + setLayoutTopLevelP $ mapM_ markAddApiAnn (al_close $ am_decls $ anns an) + -- markOptional GHC.AnnCloseC -- Possible '}' + + -- markEOF + -- eof <- getEofPos + -- debugM $ "eof pos:" ++ show (rs2range eof) + -- setLayoutTopLevelP $ printStringAtKw' eof "" + +-- --------------------------------------------------------------------- + +-- TODO:AZ: do we *need* the following, or can we capture it in the AST? +-- | We can have a list with its own entry point defined. Create a +-- data structure to capture this, for defining an ExactPrint instance +data AnnotatedList a = AnnotatedList (Maybe Anchor) a + deriving (Eq,Show) + +instance (ExactPrint a) => ExactPrint (AnnotatedList a) where + getAnnotationEntry (AnnotatedList (Just anc) _) = Entry anc (AnnComments []) + getAnnotationEntry (AnnotatedList Nothing _) = NoEntryVal + + exact (AnnotatedList an ls) = do + debugM $ "AnnotatedList:an=" ++ show an + markAnnotatedWithLayout ls + + +-- --------------------------------------------------------------------- +-- Start of utility functions +-- --------------------------------------------------------------------- + +printSourceText :: SourceText -> String -> EPP () +printSourceText NoSourceText txt = printStringAdvance txt +printSourceText (SourceText txt) _ = printStringAdvance txt + +-- --------------------------------------------------------------------- + +printStringAtRs :: RealSrcSpan -> String -> EPP () +printStringAtRs ss str = printStringAtKw' ss str + +printStringAtSs :: SrcSpan -> String -> EPP () +printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str + +-- --------------------------------------------------------------------- + +-- AZ:TODO get rid of this +printStringAtMkw :: Maybe AnnAnchor -> String -> EPP () +printStringAtMkw (Just aa) s = printStringAtAA aa s +printStringAtMkw Nothing s = printStringAtLsDelta (DP 0 1) s + + +printStringAtAA :: AnnAnchor -> String -> EPP () +printStringAtAA (AR r) s = printStringAtKw' r s +printStringAtAA (AD d) s = do + pe <- getPriorEndD + p1 <- getPosP + printStringAtLsDelta d s + p2 <- getPosP + debugM $ "printStringAtAA:(pe,p1,p2)=" ++ show (pe,p1,p2) + setPriorEndASTPD True (p1,p2) + +-- Based on Delta.addAnnotationWorker +printStringAtKw' :: RealSrcSpan -> String -> EPP () +printStringAtKw' pa str = do + printComments pa + pe <- getPriorEndD + debugM $ "printStringAtKw':pe=" ++ show pe + let p = ss2delta pe pa + p' <- adjustDeltaForOffsetM p + printStringAtLsDelta p' str + setPriorEndASTD True pa + +-- --------------------------------------------------------------------- + +markExternalSourceText :: SrcSpan -> SourceText -> String -> EPP () +markExternalSourceText l NoSourceText txt = printStringAtKw' (realSrcSpan l) txt +markExternalSourceText l (SourceText txt) _ = printStringAtKw' (realSrcSpan l) txt + +-- --------------------------------------------------------------------- + +markAddApiAnn :: AddApiAnn -> EPP () +markAddApiAnn a@(AddApiAnn kw _) = mark [a] kw + +markLocatedMAA :: ApiAnn' a -> (a -> Maybe AddApiAnn) -> EPP () +markLocatedMAA ApiAnnNotUsed _ = return () +markLocatedMAA (ApiAnn _ a _) f = + case f a of + Nothing -> return () + Just aa -> markAddApiAnn aa + +markLocatedAA :: ApiAnn' a -> (a -> AddApiAnn) -> EPP () +markLocatedAA ApiAnnNotUsed _ = return () +markLocatedAA (ApiAnn _ a _) f = markKw (f a) + +markLocatedAAL :: ApiAnn' a -> (a -> [AddApiAnn]) -> AnnKeywordId -> EPP () +markLocatedAAL ApiAnnNotUsed _ _ = return () +markLocatedAAL (ApiAnn _ a _) f kw = go (f a) + where + go [] = return () + go (aa@(AddApiAnn kw' _):as) + | kw' == kw = mark [aa] kw + | otherwise = go as + +markLocatedAALS :: ApiAnn' a -> (a -> [AddApiAnn]) -> AnnKeywordId -> Maybe String -> EPP () +markLocatedAALS an f kw Nothing = markLocatedAAL an f kw +markLocatedAALS ApiAnnNotUsed _ _ _ = return () +markLocatedAALS (ApiAnn _ a _) f kw (Just str) = go (f a) + where + go [] = return () + go (AddApiAnn kw' r:as) + | kw' == kw = printStringAtAA r str + | otherwise = go as + +-- --------------------------------------------------------------------- + +markArrow :: ApiAnn' TrailingAnn -> HsArrow GhcPs -> EPP () +markArrow ApiAnnNotUsed _ = pure () +markArrow an _mult = markKwT (anns an) + +-- --------------------------------------------------------------------- + +markAnnCloseP :: ApiAnn' AnnPragma -> EPP () +markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}") + +markAnnOpenP :: ApiAnn' AnnPragma -> SourceText -> String -> EPP () +markAnnOpenP an NoSourceText txt = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) +markAnnOpenP an (SourceText txt) _ = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) + +markAnnOpen :: ApiAnn -> SourceText -> String -> EPP () +markAnnOpen an NoSourceText txt = markLocatedAALS an id AnnOpen (Just txt) +markAnnOpen an (SourceText txt) _ = markLocatedAALS an id AnnOpen (Just txt) + +markAnnOpen' :: Maybe AnnAnchor -> SourceText -> String -> EPP () +markAnnOpen' ms NoSourceText txt = printStringAtMkw ms txt +markAnnOpen' ms (SourceText txt) _ = printStringAtMkw ms txt + +-- --------------------------------------------------------------------- + +markOpeningParen, markClosingParen :: ApiAnn' AnnParen -> EPP () +markOpeningParen an = markParen an fst +markClosingParen an = markParen an snd + +markParen :: ApiAnn' AnnParen -> (forall a. (a,a) -> a) -> EPP () +markParen ApiAnnNotUsed _ = return () +markParen (ApiAnn _ (AnnParen pt o c) _) f = markKwA (f $ kw pt) (f (o, c)) + where + kw AnnParens = (AnnOpenP, AnnCloseP) + kw AnnParensHash = (AnnOpenPH, AnnClosePH) + kw AnnParensSquare = (AnnOpenS, AnnCloseS) + + +markAnnKw :: ApiAnn' a -> (a -> AnnAnchor) -> AnnKeywordId -> EPP () +markAnnKw ApiAnnNotUsed _ _ = return () +markAnnKw (ApiAnn _ a _) f kw = markKwA kw (f a) + +markAnnKwAll :: ApiAnn' a -> (a -> [AnnAnchor]) -> AnnKeywordId -> EPP () +markAnnKwAll ApiAnnNotUsed _ _ = return () +markAnnKwAll (ApiAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) + +markAnnKwM :: ApiAnn' a -> (a -> Maybe AnnAnchor) -> AnnKeywordId -> EPP () +markAnnKwM ApiAnnNotUsed _ _ = return () +markAnnKwM (ApiAnn _ a _) f kw = go (f a) + where + go Nothing = return () + go (Just s) = markKwA kw s + +markALocatedA :: ApiAnn' AnnListItem -> EPP () +markALocatedA ApiAnnNotUsed = return () +markALocatedA (ApiAnn _ a _) = markTrailing (lann_trailing a) + +markApiAnn :: ApiAnn -> AnnKeywordId -> EPP () +markApiAnn ApiAnnNotUsed _ = return () +markApiAnn (ApiAnn _ a _) kw = mark a kw + +markApiAnn' :: ApiAnn' ann -> (ann -> [AddApiAnn]) -> AnnKeywordId -> EPP () +markApiAnn' ApiAnnNotUsed _ _ = return () +markApiAnn' (ApiAnn _ a _) f kw = mark (f a) kw + +markApiAnnAll :: ApiAnn' ann -> (ann -> [AddApiAnn]) -> AnnKeywordId -> EPP () +markApiAnnAll ApiAnnNotUsed _ _ = return () +markApiAnnAll (ApiAnn _ a _) f kw = mapM_ markKw (sort anns) + where + anns = filter (\(AddApiAnn ka _) -> ka == kw) (f a) + +mark :: [AddApiAnn] -> AnnKeywordId -> EPP () +mark anns kw = do + case find (\(AddApiAnn k _) -> k == kw) anns of + Just aa -> markKw aa + Nothing -> case find (\(AddApiAnn k _) -> k == (unicodeAnn kw)) anns of + Just aau -> markKw aau + Nothing -> return () + +markKwT :: TrailingAnn -> EPP () +markKwT (AddSemiAnn ss) = markKwA AnnSemi ss +markKwT (AddCommaAnn ss) = markKwA AnnComma ss +markKwT (AddVbarAnn ss) = markKwA AnnVbar ss +markKwT (AddRarrowAnn ss) = markKwA AnnRarrow ss +markKwT (AddRarrowAnnU ss) = markKwA AnnRarrowU ss +-- markKwT (AddLollyAnn ss) = markKwA AnnLolly ss +-- markKwT (AddLollyAnnU ss) = markKwA AnnLollyU ss + +markKw :: AddApiAnn -> EPP () +markKw (AddApiAnn kw ss) = markKwA kw ss + +-- | This should be the main driver of the process, managing comments +markKwA :: AnnKeywordId -> AnnAnchor -> EPP () +markKwA kw aa = printStringAtAA aa (keywordToString (G kw)) + +-- --------------------------------------------------------------------- + +markAnnList :: ApiAnn' AnnList -> EPP () -> EPP () +markAnnList ApiAnnNotUsed action = action +markAnnList an@(ApiAnn _ ann _) action = do + p <- getPosP + debugM $ "markAnnList : " ++ showPprUnsafe (p, an) + markLocatedMAA an al_open + action + markLocatedMAA an al_close + debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann) + markTrailing (al_trailing ann) + +-- --------------------------------------------------------------------- + +-- printTrailingComments :: EPP () +-- printTrailingComments = do +-- cs <- getUnallocatedComments +-- mapM_ printOneComment cs + +-- --------------------------------------------------------------------- + +printComments :: RealSrcSpan -> EPP () +printComments ss = do + cs <- commentAllocation ss + debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) + mapM_ printOneComment cs + +-- --------------------------------------------------------------------- + +printOneComment :: Comment -> EPP () +printOneComment c@(Comment _str loc _mo) = do + debugM $ "printOneComment:c=" ++ showGhc c + dp <-case anchor_op loc of + MovedAnchor dp -> return dp + _ -> do + pe <- getPriorEndD + let dp = ss2delta pe (anchor loc) + debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc) + return dp + dp'' <- adjustDeltaForOffsetM dp + mep <- getExtraDP + dp' <- case mep of + Nothing -> return dp'' + Just (Anchor _ (MovedAnchor edp)) -> do + -- setExtraDP Nothing + debugM $ "printOneComment:edp=" ++ show edp + return edp + Just (Anchor r _) -> do + pe <- getPriorEndD + let dp' = ss2delta pe r + debugM $ "printOneComment:extraDP(dp,pe,anchor loc)=" ++ showGhc (dp',pe,ss2pos r) + return dp + LayoutStartCol dOff <- gets dLHS + debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff) + setPriorEndD (ss2posEnd (anchor loc)) + printQueuedComment (anchor loc) c dp' + +-- --------------------------------------------------------------------- + +commentAllocation :: RealSrcSpan -> EPP [Comment] +commentAllocation ss = do + cs <- getUnallocatedComments + let (earlier,later) = partition (\(Comment _str loc _mo) -> anchor loc <= ss) cs + putUnallocatedComments later + -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) + return earlier + +-- --------------------------------------------------------------------- + + +markAnnotatedWithLayout :: ExactPrint ast => ast -> EPP () +markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a + +-- --------------------------------------------------------------------- + +markTopLevelList :: ExactPrint ast => [ast] -> EPP () +markTopLevelList ls = mapM_ (\a -> setLayoutTopLevelP $ markAnnotated a) ls + +-- --------------------------------------------------------------------- + +instance ExactPrint ModuleName where + getAnnotationEntry _ = NoEntryVal + exact n = do + debugM $ "ModuleName: " ++ showPprUnsafe n + withPpr n + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP WarningTxt) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn an _) (WarningTxt (L _ src) ws)) = do + markAnnOpenP an src "{-# WARNING" + markLocatedAAL an apr_rest AnnOpenS + markAnnotated ws + markLocatedAAL an apr_rest AnnCloseS + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (DeprecatedTxt (L _ src) ws)) = do + markAnnOpenP an src "{-# DEPRECATED" + markLocatedAAL an apr_rest AnnOpenS + markAnnotated ws + markLocatedAAL an apr_rest AnnCloseS + markAnnCloseP an + +-- --------------------------------------------------------------------- + +instance ExactPrint (ImportDecl GhcPs) where + getAnnotationEntry idecl = fromAnn (ideclExt idecl) + exact x@(ImportDecl ApiAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x + exact (ImportDecl ann@(ApiAnn _ an _) msrc (L lm modname) mpkg _src safeflag qualFlag _impl mAs hiding) = do + + markAnnKw ann importDeclAnnImport AnnImport + + -- "{-# SOURCE" and "#-}" + case msrc of + SourceText _txt -> do + debugM $ "ImportDecl sourcetext" + let mo = fmap fst $ importDeclAnnPragma an + let mc = fmap snd $ importDeclAnnPragma an + markAnnOpen' mo msrc "{-# SOURCE" + printStringAtMkw mc "#-}" + NoSourceText -> return () + when safeflag (markAnnKwM ann importDeclAnnSafe AnnSafe) + case qualFlag of + QualifiedPre -- 'qualified' appears in prepositive position. + -> printStringAtMkw (importDeclAnnQualified an) "qualified" + _ -> return () + case mpkg of + Just (StringLiteral src v _) -> + printStringAtMkw (importDeclAnnPackage an) (sourceTextToString src (show v)) + _ -> return () + + printStringAtKw' (realSrcSpan lm) (moduleNameString modname) + + case qualFlag of + QualifiedPost -- 'qualified' appears in postpositive position. + -> printStringAtMkw (importDeclAnnQualified an) "qualified" + _ -> return () + + case mAs of + Nothing -> return () + Just (L l mn) -> do + printStringAtMkw (importDeclAnnAs an) "as" + printStringAtKw' (realSrcSpan l) (moduleNameString mn) + + case hiding of + Nothing -> return () + Just (_isHiding,lie) -> exact lie + -- markTrailingSemi + + +-- --------------------------------------------------------------------- + +instance ExactPrint HsDocString where + getAnnotationEntry _ = NoEntryVal + exact = withPpr -- TODO:AZ use annotations + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDecl GhcPs) where + getAnnotationEntry (TyClD _ _) = NoEntryVal + getAnnotationEntry (InstD _ _) = NoEntryVal + getAnnotationEntry (DerivD _ _) = NoEntryVal + getAnnotationEntry (ValD _ _) = NoEntryVal + getAnnotationEntry (SigD _ _) = NoEntryVal + getAnnotationEntry (KindSigD _ _) = NoEntryVal + getAnnotationEntry (DefD _ _) = NoEntryVal + getAnnotationEntry (ForD _ _) = NoEntryVal + getAnnotationEntry (WarningD _ _) = NoEntryVal + getAnnotationEntry (AnnD _ _) = NoEntryVal + getAnnotationEntry (RuleD _ _) = NoEntryVal + getAnnotationEntry (SpliceD _ _) = NoEntryVal + getAnnotationEntry (DocD _ _) = NoEntryVal + getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal + + exact (TyClD _ d) = markAnnotated d + exact (InstD _ d) = markAnnotated d + exact (DerivD _ d) = markAnnotated d + exact (ValD _ d) = markAnnotated d + exact (SigD _ d) = markAnnotated d + exact (KindSigD _ d) = markAnnotated d + exact (DefD _ d) = markAnnotated d + exact (ForD _ d) = markAnnotated d + exact (WarningD _ d) = markAnnotated d + exact (AnnD _ d) = markAnnotated d + exact (RuleD _ d) = markAnnotated d + exact (SpliceD _ d) = markAnnotated d + exact (DocD _ d) = markAnnotated d + exact (RoleAnnotD _ d) = markAnnotated d + +-- --------------------------------------------------------------------- + +instance ExactPrint (InstDecl GhcPs) where + getAnnotationEntry (ClsInstD _ _) = NoEntryVal + getAnnotationEntry (DataFamInstD an _) = fromAnn an + getAnnotationEntry (TyFamInstD _ _) = NoEntryVal + +-- instance Annotate (GHC.InstDecl GHC.GhcPs) where + +-- markAST l (GHC.ClsInstD _ cid) = markAST l cid +-- markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid +-- markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid +-- markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showPprUnsafe x + + exact (ClsInstD _ cid) = markAnnotated cid + exact (DataFamInstD an decl) = do + exactDataFamInstDecl an TopLevel decl + exact (TyFamInstD _ eqn) = do + -- exactTyFamInstDecl an TopLevel eqn + markAnnotated eqn + +-- --------------------------------------------------------------------- + +exactDataFamInstDecl :: ApiAnn -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP () +exactDataFamInstDecl an top_lvl + (DataFamInstDecl ( FamEqn { feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn })) + = exactDataDefn an pp_hdr defn + where + pp_hdr mctxt = do + case top_lvl of + TopLevel -> markApiAnn an AnnInstance -- TODO: maybe in toplevel + NotTopLevel -> return () + exactHsFamInstLHS an tycon bndrs pats fixity mctxt + +-- --------------------------------------------------------------------- + +exactTyFamInstDecl :: TopLevelFlag -> (TyFamInstDecl GhcPs) -> EPP () +exactTyFamInstDecl top_lvl (TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do + markApiAnn an AnnType + case top_lvl of + TopLevel -> markApiAnn an AnnInstance + NotTopLevel -> return () + markAnnotated eqn + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivDecl GhcPs) where + getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an + exact (DerivDecl an typ ms mov) = do + markApiAnn an AnnDeriving + mapM_ markAnnotated ms + markApiAnn an AnnInstance + mapM_ markAnnotated mov + markAnnotated typ + -- markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do + -- mark GHC.AnnDeriving + -- markMaybe ms + -- mark GHC.AnnInstance + -- markMaybe mov + -- markLocated typ + -- markTrailingSemi + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignDecl GhcPs) where + getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an + getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an + + exact (ForeignImport an n ty fimport) = do + markApiAnn an AnnForeign + markApiAnn an AnnImport + + markAnnotated fimport + + markAnnotated n + markApiAnn an AnnDcolon + markAnnotated ty + exact x = error $ "ForDecl: exact for " ++ showAst x +{- + markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) + (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do + mark GHC.AnnForeign + mark GHC.AnnImport + + markLocated cconv + unless (ll == GHC.noSrcSpan) $ markLocated safety + markExternalSourceText ls src "" + + markLocated ln + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + +-} + + +-- --------------------------------------------------------------------- + +instance ExactPrint ForeignImport where + getAnnotationEntry = const NoEntryVal + exact (CImport cconv safety@(L ll _) _mh _imp (L ls src)) = do + markAnnotated cconv + unless (ll == noSrcSpan) $ markAnnotated safety + unless (ls == noSrcSpan) $ markExternalSourceText ls src "" + +-- --------------------------------------------------------------------- + +instance ExactPrint Safety where + getAnnotationEntry = const NoEntryVal + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint CCallConv where + getAnnotationEntry = const NoEntryVal + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecls GhcPs) where + getAnnotationEntry (Warnings an _ _) = fromAnn an + exact (Warnings an src warns) = do + markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED + markAnnotated warns + markLocatedAALS an id AnnClose (Just "#-}") + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecl GhcPs) where + getAnnotationEntry (Warning an _ _) = fromAnn an + + exact (Warning an lns txt) = do + markAnnotated lns + markApiAnn an AnnOpenS -- "[" + case txt of + WarningTxt _src ls -> markAnnotated ls + DeprecatedTxt _src ls -> markAnnotated ls + markApiAnn an AnnCloseS -- "]" + +-- --------------------------------------------------------------------- + +instance ExactPrint StringLiteral where + getAnnotationEntry = const NoEntryVal + + exact (StringLiteral src fs mcomma) = do + printSourceText src (show (unpackFS fs)) + mapM_ (\r -> printStringAtKw' r ",") mcomma + +-- --------------------------------------------------------------------- + +instance ExactPrint FastString where + getAnnotationEntry = const NoEntryVal + + -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. + -- exact fs = printStringAdvance (show (unpackFS fs)) + exact fs = printStringAdvance (unpackFS fs) + + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecls GhcPs) where + getAnnotationEntry (HsRules an _ _) = fromAnn an + exact (HsRules an src rules) = do + case src of + NoSourceText -> markLocatedAALS an id AnnOpen (Just "{-# RULES") + SourceText srcTxt -> markLocatedAALS an id AnnOpen (Just srcTxt) + markAnnotated rules + markLocatedAALS an id AnnClose (Just "#-}") + -- markTrailingSemi + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecl GhcPs) where + getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an + exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do + debugM "HsRule entered" + markAnnotated ln + debugM "HsRule after ln" + markActivation an ra_rest act + debugM "HsRule after act" + case mtybndrs of + Nothing -> return () + Just bndrs -> do + markLocatedMAA an (\a -> fmap fst (ra_tyanns a)) -- AnnForall + mapM_ markAnnotated bndrs + markLocatedMAA an (\a -> fmap snd (ra_tyanns a)) -- AnnDot + + markLocatedMAA an (\a -> fmap fst (ra_tmanns a)) -- AnnForall + mapM_ markAnnotated termbndrs + markLocatedMAA an (\a -> fmap snd (ra_tmanns a)) -- AnnDot + + markAnnotated lhs + markApiAnn' an ra_rest AnnEqual + markAnnotated rhs + -- markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do + -- markLocated ln + -- setContext (Set.singleton ExplicitNeverActive) $ markActivation l act + + + -- mark GHC.AnnForall + -- mapM_ markLocated termbndrs + -- mark GHC.AnnDot + + -- markLocated lhs + -- mark GHC.AnnEqual + -- markLocated rhs + -- inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + -- markTrailingSemi + +markActivation :: ApiAnn' a -> (a -> [AddApiAnn]) -> Activation -> Annotated () +markActivation an fn act = do + case act of + ActiveBefore src phase -> do + markApiAnn' an fn AnnOpenS -- '[' + markApiAnn' an fn AnnTilde -- ~ + markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + markApiAnn' an fn AnnCloseS -- ']' + ActiveAfter src phase -> do + markApiAnn' an fn AnnOpenS -- '[' + markLocatedAALS an fn AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) + markApiAnn' an fn AnnCloseS -- ']' + NeverActive -> do + markApiAnn' an fn AnnOpenS -- '[' + markApiAnn' an fn AnnTilde -- ~ + markApiAnn' an fn AnnCloseS -- ']' + _ -> return () + +-- --------------------------------------------------------------------- + +instance ExactPrint (SpliceDecl GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (SpliceDecl _ splice _flag) = do + markAnnotated splice + +-- --------------------------------------------------------------------- + +instance ExactPrint DocDecl where + getAnnotationEntry = const NoEntryVal + + exact v = + let str = + case v of + (DocCommentNext ds) -> unpackHDS ds + (DocCommentPrev ds) -> unpackHDS ds + (DocCommentNamed _s ds) -> unpackHDS ds + (DocGroup _i ds) -> unpackHDS ds + in + printStringAdvance str + +-- --------------------------------------------------------------------- + +instance ExactPrint (RoleAnnotDecl GhcPs) where + getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an + exact (RoleAnnotDecl an ltycon roles) = do + markApiAnn an AnnType + markApiAnn an AnnRole + markAnnotated ltycon + markAnnotated roles + +-- --------------------------------------------------------------------- + +instance ExactPrint Role where + getAnnotationEntry = const NoEntryVal + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleBndr GhcPs) where + getAnnotationEntry = const NoEntryVal + +{- + = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass) +-} + exact (RuleBndr _ ln) = markAnnotated ln + exact (RuleBndrSig an ln (HsPS _ ty)) = do + markApiAnn an AnnOpenP -- "(" + markAnnotated ln + markApiAnn an AnnDcolon + markAnnotated ty + markApiAnn an AnnCloseP -- ")" + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (TyFamInstEqn GhcPs) where +-- instance (ExactPrint body) => ExactPrint (FamInstEqn GhcPs body) where +-- getAnnotationEntry = const NoEntryVal +-- exact (HsIB { hsib_body = FamEqn { feqn_ext = an +-- , feqn_tycon = tycon +-- , feqn_bndrs = bndrs +-- , feqn_pats = pats +-- , feqn_fixity = fixity +-- , feqn_rhs = rhs }}) = do +-- exactHsFamInstLHS an tycon bndrs pats fixity Nothing +-- markApiAnn an AnnEqual +-- markAnnotated rhs + +instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where + getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an + exact (FamEqn { feqn_ext = an + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }) = do + exactHsFamInstLHS an tycon bndrs pats fixity Nothing + markApiAnn an AnnEqual + markAnnotated rhs + +-- --------------------------------------------------------------------- + +exactHsFamInstLHS :: + ApiAnn + -> LocatedN RdrName + -- -> Maybe [LHsTyVarBndr () GhcPs] + -> HsOuterTyVarBndrs () GhcPs + -> HsTyPats GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EPP () +exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do + markApiAnn an AnnForall + markAnnotated bndrs + markApiAnn an AnnDot + mapM_ markAnnotated mb_ctxt + exact_pats typats + where + exact_pats :: HsTyPats GhcPs -> EPP () + exact_pats (patl:patr:pats) + | Infix <- fixity + = let exact_op_app = do + markAnnotated patl + markAnnotated thing + markAnnotated patr + in case pats of + [] -> exact_op_app + _ -> do + markApiAnn an AnnOpenP + exact_op_app + markApiAnn an AnnCloseP + mapM_ markAnnotated pats + + exact_pats pats = do + markAnnotated thing + markAnnotated pats + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (LHsTypeArg GhcPs) where +instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) + => ExactPrint (HsArg tm ty) where + getAnnotationEntry = const NoEntryVal + + exact (HsValArg tm) = markAnnotated tm + exact (HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty + exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source + +-- --------------------------------------------------------------------- + +-- instance ExactPrint [LHsTyVarBndr () GhcPs] where +-- getAnnotationEntry = const NoEntryVal +-- exact bs = mapM_ markAnnotated bs + +-- --------------------------------------------------------------------- + +instance ExactPrint (ClsInstDecl GhcPs) where + getAnnotationEntry cid = fromAnn (fst $ cid_ext cid) + + exact (ClsInstDecl { cid_ext = (an, sortKey) + , cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part + = top_matter + + | otherwise -- Laid out + = do + top_matter + markApiAnn an AnnWhere + markApiAnn an AnnOpenC + -- = vcat [ top_matter <+> text "where" + -- , nest 2 $ pprDeclList $ + -- map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ + -- map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ + -- pprLHsBindsForUser binds sigs ] + withSortKey sortKey + (prepareListAnnotationA ats + ++ prepareListAnnotationF (exactDataFamInstDecl an NotTopLevel ) adts + ++ prepareListAnnotationA (bagToList binds) + ++ prepareListAnnotationA sigs + ) + markApiAnn an AnnCloseC -- '}' + + where + top_matter = do + markApiAnn an AnnInstance + mapM_ markAnnotated mbOverlap + markAnnotated inst_ty + markApiAnn an AnnWhere -- Optional + -- text "instance" <+> ppOverlapPragma mbOverlap + -- <+> ppr inst_ty + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyFamInstDecl GhcPs) where + getAnnotationEntry (TyFamInstDecl an _) = fromAnn an + exact d@(TyFamInstDecl _an _eqn) = + exactTyFamInstDecl TopLevel d + +-- --------------------------------------------------------------------- + +-- instance (ExactPrint body) => ExactPrint (HsImplicitBndrs GhcPs body) where +-- getAnnotationEntry (HsIB an _) = fromAnn an +-- exact (HsIB an t) = markAnnotated t + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP OverlapMode) where + getAnnotationEntry = entryFromLocatedA + + -- NOTE: NoOverlap is only used in the typechecker + exact (L (SrcSpanAnn an _) (NoOverlap src)) = do + markAnnOpenP an src "{-# NO_OVERLAP" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Overlappable src)) = do + markAnnOpenP an src "{-# OVERLAPPABLE" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Overlapping src)) = do + markAnnOpenP an src "{-# OVERLAPPING" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Overlaps src)) = do + markAnnOpenP an src "{-# OVERLAPS" + markAnnCloseP an + + exact (L (SrcSpanAnn an _) (Incoherent src)) = do + markAnnOpenP an src "{-# INCOHERENT" + markAnnCloseP an + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsBind GhcPs) where + getAnnotationEntry FunBind{} = NoEntryVal + getAnnotationEntry PatBind{} = NoEntryVal + getAnnotationEntry VarBind{} = NoEntryVal + getAnnotationEntry AbsBinds{} = NoEntryVal + getAnnotationEntry PatSynBind{} = NoEntryVal + + exact (FunBind _ _ matches _) = do + markAnnotated matches + exact (PatBind _ pat grhss _) = do + markAnnotated pat + markAnnotated grhss + exact (PatSynBind _ bind) = markAnnotated bind + + exact x = error $ "HsBind: exact for " ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (PatSynBind GhcPs GhcPs) where + getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an + + exact (PSB{ psb_ext = an + , psb_id = psyn, psb_args = details + , psb_def = pat + , psb_dir = dir }) = do + markApiAnn an AnnPattern + case details of + InfixCon v1 v2 -> do + markAnnotated v1 + markAnnotated psyn + markAnnotated v2 + PrefixCon tvs vs -> do + markAnnotated psyn + markAnnotated tvs + markAnnotated vs + RecCon vs -> do + markAnnotated psyn + markApiAnn an AnnOpenC -- '{' + markAnnotated vs + markApiAnn an AnnCloseC -- '}' + + case dir of + Unidirectional -> do + markApiAnn an AnnLarrow + markAnnotated pat + ImplicitBidirectional -> do + markApiAnn an AnnEqual + markAnnotated pat + ExplicitBidirectional mg -> do + markApiAnn an AnnLarrow + markAnnotated pat + markApiAnn an AnnWhere + markAnnotated mg + + -- case dir of + -- GHC.ImplicitBidirectional -> mark GHC.AnnEqual + -- _ -> mark GHC.AnnLarrow + + -- markLocated def + -- case dir of + -- GHC.Unidirectional -> return () + -- GHC.ImplicitBidirectional -> return () + -- GHC.ExplicitBidirectional mg -> do + -- mark GHC.AnnWhere + -- mark GHC.AnnOpenC -- '{' + -- markMatchGroup l mg + -- mark GHC.AnnCloseC -- '}' + + -- markTrailingSemi + + +-- --------------------------------------------------------------------- + +instance ExactPrint (RecordPatSynField GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (RecordPatSynField { recordPatSynField = v }) = markAnnotated v + +-- --------------------------------------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (Match ann _ _ _) = fromAnn ann + + exact match@(Match ApiAnnNotUsed _ _ _) = withPpr match + exact (Match an mctxt pats grhss) = do + exactMatch (Match an mctxt pats grhss) + +-- ------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (Match ann _ _ _) = fromAnn ann + + exact match@(Match ApiAnnNotUsed _ _ _) = withPpr match + exact (Match an mctxt pats grhss) = do + exactMatch (Match an mctxt pats grhss) + -- -- Based on Expr.pprMatch + + -- debugM $ "exact Match entered" + + -- -- herald + -- case mctxt of + -- FunRhs fun fixity strictness -> do + -- debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun + -- case strictness of + -- SrcStrict -> markApiAnn an AnnBang + -- _ -> pure () + -- case fixity of + -- Prefix -> do + -- markAnnotated fun + -- mapM_ markAnnotated pats + -- Infix -> + -- case pats of + -- (p1:p2:rest) + -- | null rest -> do + -- markAnnotated p1 + -- markAnnotated fun + -- markAnnotated p2 + -- | otherwise -> do + -- markApiAnn an AnnOpenP + -- markAnnotated p1 + -- markAnnotated fun + -- markAnnotated p2 + -- markApiAnn an AnnCloseP + -- mapM_ markAnnotated rest + -- LambdaExpr -> do + -- markApiAnn an AnnLam + -- mapM_ markAnnotated pats + -- GHC.CaseAlt -> do + -- mapM_ markAnnotated pats + -- _ -> withPpr mctxt + + -- markAnnotated grhss + +-- --------------------------------------------------------------------- + +exactMatch :: (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> Annotated () +exactMatch (Match an mctxt pats grhss) = do +-- Based on Expr.pprMatch + + debugM $ "exact Match entered" + + -- herald + case mctxt of + FunRhs fun fixity strictness -> do + debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun + case strictness of + SrcStrict -> markApiAnn an AnnBang + _ -> pure () + case fixity of + Prefix -> do + markAnnotated fun + markAnnotated pats + Infix -> + case pats of + (p1:p2:rest) + | null rest -> do + markAnnotated p1 + markAnnotated fun + markAnnotated p2 + | otherwise -> do + markApiAnn an AnnOpenP + markAnnotated p1 + markAnnotated fun + markAnnotated p2 + markApiAnn an AnnCloseP + mapM_ markAnnotated rest + _ -> panic "FunRhs" + LambdaExpr -> do + markApiAnn an AnnLam + markAnnotated pats + GHC.CaseAlt -> do + markAnnotated pats + _ -> withPpr mctxt + + markAnnotated grhss + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + + exact (GRHSs _ grhss binds) = do + markAnnotated grhss + markAnnotated binds + + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + + exact (GRHSs _an grhss binds) = do + markAnnotated grhss + markAnnotated binds + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsLocalBinds GhcPs) where + getAnnotationEntry (HsValBinds an _) = fromAnn an + getAnnotationEntry (HsIPBinds{}) = NoEntryVal + getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal + + exact (HsValBinds an valbinds) = do + markLocatedAAL an al_rest AnnWhere + let manc = case an of + ApiAnnNotUsed -> Nothing + _ -> al_anchor $ anns an + + case manc of + Just anc -> do + when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) + _ -> return () + + markAnnotatedWithLayout valbinds + + exact (HsIPBinds an bs) + = markAnnList an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs) + exact (EmptyLocalBinds _) = return () + + +-- --------------------------------------------------------------------- +instance ExactPrint (HsValBindsLR GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + + exact (ValBinds sortKey binds sigs) = do + setLayoutBoth $ withSortKey sortKey + (prepareListAnnotationA (bagToList binds) + ++ prepareListAnnotationA sigs + ) + exact (XValBindsLR _) = panic "XValBindsLR" + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsIPBinds GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (IPBinds _ binds) = setLayoutBoth $ markAnnotated binds + +-- --------------------------------------------------------------------- + +instance ExactPrint (IPBind GhcPs) where + getAnnotationEntry (IPBind an _ _) = fromAnn an + + exact (IPBind an (Left lr) rhs) = do + markAnnotated lr + markApiAnn an AnnEqual + markAnnotated rhs + + exact (IPBind _ (Right _) _) = error $ "ExactPrint IPBind: Right only after typechecker" + +-- --------------------------------------------------------------------- + +instance ExactPrint HsIPName where + getAnnotationEntry = const NoEntryVal + + exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (HsValBindsLR GhcPs GhcPs) where +-- getAnnotationEntry _ = NoEntryVal + +-- exact (ValBinds sortKey binds sigs) = do +-- -- printStringAdvance "ValBinds" +-- setLayoutBoth $ withSortKey sortKey +-- (prepareListAnnotationA (bagToList binds) +-- ++ prepareListAnnotationA sigs +-- ) + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + + +-- AZ:TODO: generalise this, and the next one +-- prepareListAnnotationFamilyD :: [LFamilyDecl GhcPs] -> [(RealSrcSpan,EPP ())] +-- prepareListAnnotationFamilyD ls +-- = map (\b -> (realSrcSpan $ getLocA b,exactFamilyDecl NotTopLevel (unLoc b))) ls + +prepareListAnnotationF :: (a -> EPP ()) -> [LocatedAn an a] -> [(RealSrcSpan,EPP ())] +prepareListAnnotationF f ls + = map (\b -> (realSrcSpan $ getLocA b, f (unLoc b))) ls + +prepareListAnnotationA :: ExactPrint (LocatedAn an a) + => [LocatedAn an a] -> [(RealSrcSpan,EPP ())] +prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,markAnnotated b)) ls + + +-- applyListAnnotations :: [(RealSrcSpan, EPP ())] -> EPP () +-- applyListAnnotations ls = withSortKey ls + +withSortKey :: AnnSortKey -> [(RealSrcSpan, EPP ())] -> EPP () +withSortKey annSortKey xs = do + debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey + let ordered = case annSortKey of + NoAnnSortKey -> sortBy orderByFst xs + -- Just keys -> error $ "withSortKey: keys" ++ show keys + AnnSortKey keys -> orderByKey xs keys + -- `debug` ("withSortKey:" ++ + -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), + -- map fst xs, + -- keys) + -- ) + mapM_ snd ordered + +orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering +orderByFst (a,_) (b,_) = compare a b + +-- --------------------------------------------------------------------- + +instance ExactPrint (Sig GhcPs) where + getAnnotationEntry (TypeSig a _ _) = fromAnn a + getAnnotationEntry (PatSynSig a _ _) = fromAnn a + getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a + getAnnotationEntry (IdSig {}) = NoEntryVal + getAnnotationEntry (FixSig a _) = fromAnn a + getAnnotationEntry (InlineSig a _ _) = fromAnn a + getAnnotationEntry (SpecSig a _ _ _) = fromAnn a + getAnnotationEntry (SpecInstSig a _ _) = fromAnn a + getAnnotationEntry (MinimalSig a _ _) = fromAnn a + getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a + getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a + +-- instance Annotate (Sig GhcPs) where + + exact (TypeSig an vars ty) = exactVarSig an vars ty + + exact (PatSynSig an lns typ) = do + markLocatedAAL an asRest AnnPattern + markAnnotated lns + markLocatedAA an asDcolon + markAnnotated typ + + exact (ClassOpSig an is_deflt vars ty) + | is_deflt = markLocatedAAL an asRest AnnDefault >> exactVarSig an vars ty + | otherwise = exactVarSig an vars ty + +-- markAST _ (IdSig {}) = +-- traceM "warning: Introduced after renaming" + + exact (FixSig an (FixitySig _ names (Fixity src v fdir))) = do + let fixstr = case fdir of + InfixL -> "infixl" + InfixR -> "infixr" + InfixN -> "infix" + markLocatedAALS an id AnnInfix (Just fixstr) +-- markSourceText src (show v) + markLocatedAALS an id AnnVal (Just (sourceTextToString src (show v))) + markAnnotated names + + + exact (InlineSig an ln inl) = do + markAnnOpen an (inl_src inl) "{-# INLINE" + -- markActivation l (inl_act inl) + markActivation an id (inl_act inl) + markAnnotated ln + -- markWithString AnnClose "#-}" -- '#-}' + debugM $ "InlineSig:an=" ++ showAst an + p <- getPosP + debugM $ "InlineSig: p=" ++ show p + markLocatedAALS an id AnnClose (Just "#-}") + debugM $ "InlineSig:done" + + exact (SpecSig an ln typs inl) = do + markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + markActivation an id (inl_act inl) + markAnnotated ln + markApiAnn an AnnDcolon + markAnnotated typs + markLocatedAALS an id AnnClose (Just "#-}") + + exact (SpecInstSig an src typ) = do + markAnnOpen an src "{-# SPECIALISE" + markApiAnn an AnnInstance + markAnnotated typ + markLocatedAALS an id AnnClose (Just "#-}") + +-- markAST _ (SpecInstSig _ src typ) = do +-- markAnnOpen src "{-# SPECIALISE" +-- mark AnnInstance +-- markLHsSigType typ +-- markWithString AnnClose "#-}" -- '#-}' +-- markTrailingSemi + + exact (MinimalSig an src formula) = do + markAnnOpen an src "{-# MINIMAL" + markAnnotated formula + markLocatedAALS an id AnnClose (Just "#-}") + +-- markAST _ (MinimalSig _ src formula) = do +-- markAnnOpen src "{-# MINIMAL" +-- markLocated formula +-- markWithString AnnClose "#-}" +-- markTrailingSemi + + exact (SCCFunSig an src ln ml) = do + markAnnOpen an src "{-# SCC" + markAnnotated ln + markAnnotated ml + markLocatedAALS an id AnnClose (Just "#-}") + +-- markAST _ (CompleteMatchSig _ src (L _ ns) mlns) = do +-- markAnnOpen src "{-# COMPLETE" +-- markListIntercalate ns +-- case mlns of +-- Nothing -> return () +-- Just _ -> do +-- mark AnnDcolon +-- markMaybe mlns +-- markWithString AnnClose "#-}" -- '#-}' +-- markTrailingSemi + + exact x = error $ "exact Sig for:" ++ showAst x + +-- --------------------------------------------------------------------- + +exactVarSig :: (ExactPrint a) => ApiAnn' AnnSig -> [LocatedN RdrName] -> a -> EPP () +exactVarSig an vars ty = do + mapM_ markAnnotated vars + markLocatedAA an asDcolon + markAnnotated ty + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (FixitySig GhcPs) where +-- getAnnotationEntry = const NoEntryVal + +-- exact (FixitySig an names (Fixity src v fdir)) = do +-- let fixstr = case fdir of +-- InfixL -> "infixl" +-- InfixR -> "infixr" +-- InfixN -> "infix" +-- markAnnotated names +-- markLocatedAALS an id AnnInfix (Just fixstr) +-- -- markAST _ (FixSig _ (FixitySig _ lns (Fixity src v fdir))) = do +-- -- let fixstr = case fdir of +-- -- InfixL -> "infixl" +-- -- InfixR -> "infixr" +-- -- InfixN -> "infix" +-- -- markWithString AnnInfix fixstr +-- -- markSourceText src (show v) +-- -- setContext (Set.singleton InfixOp) $ markListIntercalate lns +-- -- markTrailingSemi +-- --------------------------------------------------------------------- + +instance ExactPrint (StandaloneKindSig GhcPs) where + getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an + + exact (StandaloneKindSig an vars sig) = do + markApiAnn an AnnType + markAnnotated vars + markApiAnn an AnnDcolon + markAnnotated sig + +-- --------------------------------------------------------------------- + +instance ExactPrint (DefaultDecl GhcPs) where + getAnnotationEntry (DefaultDecl an _) = fromAnn an + + exact (DefaultDecl an tys) = do + markApiAnn an AnnDefault + markApiAnn an AnnOpenP + markAnnotated tys + markApiAnn an AnnCloseP + +-- --------------------------------------------------------------------- + +instance ExactPrint (AnnDecl GhcPs) where + getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an + + exact (HsAnnotation an src prov e) = do + markAnnOpenP an src "{-# ANN" + case prov of + (ValueAnnProvenance n) -> markAnnotated n + (TypeAnnProvenance n) -> do + markLocatedAAL an apr_rest AnnType + markAnnotated n + ModuleAnnProvenance -> markLocatedAAL an apr_rest AnnModule + + markAnnotated e + markAnnCloseP an + +-- --------------------------------------------------------------------- + +instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where + getAnnotationEntry = const NoEntryVal + + exact (BF.Var x) = do + markAnnotated x + exact (BF.Or ls) = markAnnotated ls + exact (BF.And ls) = do + markAnnotated ls + exact (BF.Parens x) = do + -- mark AnnOpenP -- '(' + markAnnotated x + -- mark AnnCloseP -- ')' + +-- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where +-- markAST _ (GHC.Var x) = do +-- setContext (Set.singleton PrefixOp) $ markLocated x +-- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar +-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma +-- markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls +-- markAST _ (GHC.And ls) = do +-- markListIntercalateWithFunLevel markLocated 2 ls +-- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar +-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma +-- markAST _ (GHC.Parens x) = do +-- mark GHC.AnnOpenP -- '(' +-- markLocated x +-- mark GHC.AnnCloseP -- ')' +-- inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar +-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (LHsSigWcType GhcPs) where +-- instance ExactPrint (HsWildCardBndrs GhcPs (LHsSigType GhcPs)) where +instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where + getAnnotationEntry = const NoEntryVal + exact (HsWC _ ty) = markAnnotated ty + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHS an _ _) = fromAnn an + + exact (GRHS an guards expr) = do + debugM $ "GRHS comments:" ++ showGhc (comments an) + markAnnKwM an ga_vbar AnnVbar + markAnnotated guards + debugM $ "GRHS before matchSeparator" + markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs + debugM $ "GRHS after matchSeparator" + markAnnotated expr + -- markLocatedAA an ga_sep + +instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHS ann _ _) = fromAnn ann + + exact (GRHS an guards expr) = do + markAnnKwM an ga_vbar AnnVbar + markAnnotated guards + markLocatedAA an ga_sep -- Mark the matchSeparator for these GRHSs + markAnnotated expr + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsExpr GhcPs) where + getAnnotationEntry (HsVar{}) = NoEntryVal + getAnnotationEntry (HsUnboundVar an _) = fromAnn an + getAnnotationEntry (HsConLikeOut{}) = NoEntryVal + getAnnotationEntry (HsRecFld{}) = NoEntryVal + getAnnotationEntry (HsOverLabel an _) = fromAnn an + getAnnotationEntry (HsIPVar an _) = fromAnn an + getAnnotationEntry (HsOverLit an _) = fromAnn an + getAnnotationEntry (HsLit an _) = fromAnn an + getAnnotationEntry (HsLam _ _) = NoEntryVal + getAnnotationEntry (HsLamCase an _) = fromAnn an + getAnnotationEntry (HsApp an _ _) = fromAnn an + getAnnotationEntry (HsAppType _ _ _) = NoEntryVal + getAnnotationEntry (OpApp an _ _ _) = fromAnn an + getAnnotationEntry (NegApp an _ _) = fromAnn an + getAnnotationEntry (HsPar an _) = fromAnn an + getAnnotationEntry (SectionL an _ _) = fromAnn an + getAnnotationEntry (SectionR an _ _) = fromAnn an + getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an + getAnnotationEntry (ExplicitSum an _ _ _) = fromAnn an + getAnnotationEntry (HsCase an _ _) = fromAnn an + getAnnotationEntry (HsIf an _ _ _) = fromAnn an + getAnnotationEntry (HsMultiIf an _) = fromAnn an + getAnnotationEntry (HsLet an _ _) = fromAnn an + getAnnotationEntry (HsDo an _ _) = fromAnn an + getAnnotationEntry (ExplicitList an _) = fromAnn an + getAnnotationEntry (RecordCon an _ _) = fromAnn an + getAnnotationEntry (RecordUpd an _ _) = fromAnn an + getAnnotationEntry (HsGetField an _ _) = fromAnn an + getAnnotationEntry (HsProjection an _) = fromAnn an + getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an + getAnnotationEntry (ArithSeq an _ _) = fromAnn an + getAnnotationEntry (HsBracket an _) = fromAnn an + getAnnotationEntry (HsRnBracketOut{}) = NoEntryVal + getAnnotationEntry (HsTcBracketOut{}) = NoEntryVal + getAnnotationEntry (HsSpliceE an _) = fromAnn an + getAnnotationEntry (HsProc an _ _) = fromAnn an + getAnnotationEntry (HsStatic an _) = fromAnn an + getAnnotationEntry (HsTick {}) = NoEntryVal + getAnnotationEntry (HsBinTick {}) = NoEntryVal + getAnnotationEntry (HsPragE{}) = NoEntryVal + + + exact (HsVar _ n) = markAnnotated n + exact x@(HsUnboundVar an _v) = do + case an of + ApiAnnNotUsed -> withPpr x + ApiAnn _ (ApiAnnUnboundVar (ob,cb) l) _ -> do + printStringAtAA ob "`" + printStringAtAA l "_" + printStringAtAA cb "`" + -- exact x@(HsConLikeOut{}) = withPpr x + -- exact x@(HsRecFld{}) = withPpr x + -- exact x@(HsOverLabel ann _ _) = withPpr x + exact (HsIPVar _ (HsIPName n)) + = printStringAdvance ("?" ++ unpackFS n) + + exact x@(HsOverLit _an ol) = do + let str = case ol_val ol of + HsIntegral (IL src _ _) -> src + HsFractional (FL { fl_text = src }) -> src + HsIsString src _ -> src + -- markExternalSourceText l str "" + case str of + SourceText s -> printStringAdvance s + NoSourceText -> withPpr x + + exact (HsLit _an lit) = withPpr lit + exact (HsLam _ (MG _ (L _ [match]) _)) = do + markAnnotated match + -- markExpr _ (HsLam _ (MG _ (L _ [match]) _)) = do + -- setContext (Set.singleton LambdaExpr) $ do + -- -- TODO: Change this, HsLam binds do not need obey layout rules. + -- -- And will only ever have a single match + -- markLocated match + -- markExpr _ (HsLam _ _) = error $ "HsLam with other than one match" + exact (HsLam _ _) = error $ "HsLam with other than one match" + + exact (HsLamCase an mg) = do + markApiAnn an AnnLam + markApiAnn an AnnCase + markAnnotated mg + + exact (HsApp _an e1 e2) = do + p <- getPosP + debugM $ "HsApp entered. p=" ++ show p + markAnnotated e1 + markAnnotated e2 + exact (HsAppType ss fun arg) = do + markAnnotated fun + printStringAtSs ss "@" + markAnnotated arg + exact (OpApp _an e1 e2 e3) = do + exact e1 + exact e2 + exact e3 + + exact (NegApp an e _) = do + markApiAnn an AnnMinus + markAnnotated e + + exact (HsPar an e) = do + markOpeningParen an + markAnnotated e + debugM $ "HsPar closing paren" + markClosingParen an + debugM $ "HsPar done" + + -- exact (SectionL an expr op) = do + exact (SectionR _an op expr) = do + markAnnotated op + markAnnotated expr + exact (ExplicitTuple an args b) = do + if b == Boxed then markApiAnn an AnnOpenP + else markApiAnn an AnnOpenPH + + mapM_ markAnnotated args + + if b == Boxed then markApiAnn an AnnCloseP + else markApiAnn an AnnClosePH + debugM $ "ExplicitTuple done" + + exact (ExplicitSum an _alt _arity expr) = do + -- markApiAnn an AnnOpenPH + markAnnKw an aesOpen AnnOpenPH + markAnnKwAll an aesBarsBefore AnnVbar + markAnnotated expr + markAnnKwAll an aesBarsAfter AnnVbar + markAnnKw an aesClose AnnClosePH + + exact (HsCase an e alts) = do + markAnnKw an hsCaseAnnCase AnnCase + markAnnotated e + markAnnKw an hsCaseAnnOf AnnOf + markApiAnn' an hsCaseAnnsRest AnnOpenC + markApiAnnAll an hsCaseAnnsRest AnnSemi + setLayoutBoth $ markAnnotated alts + markApiAnn' an hsCaseAnnsRest AnnCloseC + + -- exact x@(HsCase ApiAnnNotUsed _ _) = withPpr x + exact (HsIf an e1 e2 e3) = do + markApiAnn an AnnIf + markAnnotated e1 + markApiAnn an AnnThen + markAnnotated e2 + markApiAnn an AnnElse + markAnnotated e3 + + exact (HsMultiIf an mg) = do + markApiAnn an AnnIf + markApiAnn an AnnOpenC -- optional + markAnnotated mg + markApiAnn an AnnCloseC -- optional + + exact (HsLet an binds e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + markAnnKw an alLet AnnLet + debugM $ "HSlet:binds coming" + setLayoutBoth $ markAnnotated binds + debugM $ "HSlet:binds done" + markAnnKw an alIn AnnIn + debugM $ "HSlet:expr coming" + markAnnotated e + + exact (HsDo an do_or_list_comp stmts) = do + debugM $ "HsDo" + markAnnList an $ exactDo an do_or_list_comp stmts + + exact (ExplicitList an es) = do + debugM $ "ExplicitList start" + markLocatedMAA an al_open + markAnnotated es + markLocatedMAA an al_close + debugM $ "ExplicitList end" + exact (RecordCon an con_id binds) = do + markAnnotated con_id + markApiAnn an AnnOpenC + markAnnotated binds + markApiAnn an AnnCloseC + exact (RecordUpd an expr fields) = do + markAnnotated expr + markApiAnn an AnnOpenC + markAnnotated fields + markApiAnn an AnnCloseC + exact (HsGetField _an expr field) = do + markAnnotated expr + markAnnotated field + exact (HsProjection an flds) = do + markAnnKw an apOpen AnnOpenP + markAnnotated flds + markAnnKw an apClose AnnCloseP + exact (ExprWithTySig an expr sig) = do + markAnnotated expr + markApiAnn an AnnDcolon + markAnnotated sig + exact (ArithSeq an _ seqInfo) = do + markApiAnn an AnnOpenS -- '[' + case seqInfo of + From e -> do + markAnnotated e + markApiAnn an AnnDotdot + FromTo e1 e2 -> do + markAnnotated e1 + markApiAnn an AnnDotdot + markAnnotated e2 + FromThen e1 e2 -> do + markAnnotated e1 + markApiAnn an AnnComma + markAnnotated e2 + markApiAnn an AnnDotdot + FromThenTo e1 e2 e3 -> do + markAnnotated e1 + markApiAnn an AnnComma + markAnnotated e2 + markApiAnn an AnnDotdot + markAnnotated e3 + markApiAnn an AnnCloseS -- ']' + + + exact (HsBracket an (ExpBr _ e)) = do + markApiAnn an AnnOpenEQ -- "[|" + markApiAnn an AnnOpenE -- "[e|" -- optional + markAnnotated e + markApiAnn an AnnCloseQ -- "|]" + exact (HsBracket an (PatBr _ e)) = do + markLocatedAALS an id AnnOpen (Just "[p|") + markAnnotated e + markApiAnn an AnnCloseQ -- "|]" + exact (HsBracket an (DecBrL _ e)) = do + markLocatedAALS an id AnnOpen (Just "[d|") + markAnnotated e + markApiAnn an AnnCloseQ -- "|]" + -- -- exact (HsBracket an (DecBrG _ _)) = + -- -- traceM "warning: DecBrG introduced after renamer" + exact (HsBracket an (TypBr _ e)) = do + markLocatedAALS an id AnnOpen (Just "[t|") + markAnnotated e + markApiAnn an AnnCloseQ -- "|]" + exact (HsBracket an (VarBr _ b e)) = do + if b + then do + markApiAnn an AnnSimpleQuote + markAnnotated e + else do + markApiAnn an AnnThTyQuote + markAnnotated e + exact (HsBracket an (TExpBr _ e)) = do + markLocatedAALS an id AnnOpen (Just "[||") + markLocatedAALS an id AnnOpenE (Just "[e||") + markAnnotated e + markLocatedAALS an id AnnClose (Just "||]") + + + -- exact x@(HsRnBracketOut{}) = withPpr x + -- exact x@(HsTcBracketOut{}) = withPpr x + exact (HsSpliceE _ sp) = markAnnotated sp + + exact (HsProc an p c) = do + debugM $ "HsProc start" + markApiAnn an AnnProc + markAnnotated p + markApiAnn an AnnRarrow + debugM $ "HsProc after AnnRarrow" + markAnnotated c + + exact (HsStatic an e) = do + markApiAnn an AnnStatic + markAnnotated e + + -- exact x@(HsTick {}) = withPpr x + -- exact x@(HsBinTick {}) = withPpr x + exact (HsPragE _ prag e) = do + markAnnotated prag + markAnnotated e + exact x = error $ "exact HsExpr for:" ++ showAst x + +-- --------------------------------------------------------------------- + +exactDo :: (ExactPrint body) + => ApiAnn' AnnList -> (HsStmtContext any) -> body -> EPP () +exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >> markAnnotatedWithLayout stmts +exactDo an GhciStmtCtxt stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts +exactDo an ArrowExpr stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts +exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >> markAnnotatedWithLayout stmts +exactDo _ ListComp stmts = markAnnotatedWithLayout stmts +exactDo _ MonadComp stmts = markAnnotatedWithLayout stmts +exactDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +exactMdo :: ApiAnn' AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP () +exactMdo an Nothing kw = markLocatedAAL an al_rest kw +exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n) + where + n = (moduleNameString module_name) ++ "." ++ (keywordToString (G kw)) + + +-- --------------------------------------------------------------------- +instance ExactPrint (HsPragE GhcPs) where + getAnnotationEntry HsPragSCC{} = NoEntryVal + + exact (HsPragSCC an st sl) = do + markAnnOpenP an st "{-# SCC" + let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) + markLocatedAALS an apr_rest AnnVal (Just txt) -- optional + markLocatedAALS an apr_rest AnnValStr (Just txt) -- optional + markAnnCloseP an + + -- markExpr _ (GHC.HsPragE _ prag e) = do + -- case prag of + -- (GHC.HsPragSCC _ src csFStr) -> do + -- markAnnOpen src "{-# SCC" + -- let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) + -- markWithStringOptional GHC.AnnVal txt + -- markWithString GHC.AnnValStr txt + -- markWithString GHC.AnnClose "#-}" + -- markLocated e + + -- (GHC.HsPragTick _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4))) -> do + -- -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + -- markAnnOpen src "{-# GENERATED" + -- markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING + + -- let + -- markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) + -- markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s + + -- markOne 1 v1 s1 -- INTEGER + -- markOffset GHC.AnnColon 0 -- ':' + -- markOne 2 v2 s2 -- INTEGER + -- mark GHC.AnnMinus -- '-' + -- markOne 3 v3 s3 -- INTEGER + -- markOffset GHC.AnnColon 1 -- ':' + -- markOne 4 v4 s4 -- INTEGER + -- markWithString GHC.AnnClose "#-}" + -- markLocated e + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsSplice GhcPs) where + getAnnotationEntry (HsTypedSplice an _ _ _) = fromAnn an + getAnnotationEntry (HsUntypedSplice an _ _ _) = fromAnn an + getAnnotationEntry (HsQuasiQuote _ _ _ _ _) = NoEntryVal + getAnnotationEntry (HsSpliced _ _ _) = NoEntryVal + + exact (HsTypedSplice an DollarSplice _n e) = do + markApiAnn an AnnDollarDollar + markAnnotated e + + -- = ppr_splice (text "$$") n e empty + -- exact (HsTypedSplice _ BareSplice _ _ ) + -- = panic "Bare typed splice" -- impossible + exact (HsUntypedSplice an decoration _n b) = do + when (decoration == DollarSplice) $ markApiAnn an AnnDollar + markAnnotated b + + -- exact (HsUntypedSplice _ DollarSplice n e) + -- = ppr_splice (text "$") n e empty + -- exact (HsUntypedSplice _ BareSplice n e) + -- = ppr_splice empty n e empty + + exact (HsQuasiQuote _ _ q ss fs) = do + -- The quasiquote string does not honour layout offsets. Store + -- the colOffset for now. + -- TODO: use local? + oldOffset <- getLayoutOffsetP + setLayoutOffsetP 0 + printStringAdvance + -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 + ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") + setLayoutOffsetP oldOffset + p <- getPosP + debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss) + + -- exact (HsSpliced _ _ thing) = ppr thing + -- exact (XSplice x) = case ghcPass @p of + exact x = error $ "exact HsSplice for:" ++ showAst x + +-- --------------------------------------------------------------------- + +-- TODO:AZ: combine these instances +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry = const NoEntryVal + exact (MG _ matches _) = do + -- TODO:AZ use SortKey, in MG ann. + markAnnotated matches + +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry = const NoEntryVal + exact (MG _ matches _) = do + -- TODO:AZ use SortKey, in MG ann. + markAnnotated matches + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where + getAnnotationEntry = const NoEntryVal + exact (HsRecFields fields mdot) = do + markAnnotated fields + case mdot of + Nothing -> return () + Just (L ss _) -> + printStringAtSs ss ".." + -- Note: mdot contains the SrcSpan where the ".." appears, if present + +-- --------------------------------------------------------------------- + +-- instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where +instance (ExactPrint body) + => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecField" + markAnnotated f + if isPun then return () + else do + markApiAnn an AnnEqual + markAnnotated arg + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsRecField' (FieldLabelStrings GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecField FieldLabelStrings" + markAnnotated f + if isPun then return () + else do + markApiAnn an AnnEqual + markAnnotated arg + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (HsRecUpdField GhcPs ) where +instance (ExactPrint body) + => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where +-- instance (ExactPrint body) + -- => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) body) where + getAnnotationEntry x = fromAnn (hsRecFieldAnn x) + exact (HsRecField an f arg isPun) = do + debugM $ "HsRecUpdField" + markAnnotated f + if isPun then return () + else markApiAnn an AnnEqual + markAnnotated arg + +-- --------------------------------------------------------------------- +-- instance (ExactPrint body) +-- => ExactPrint (Either (HsRecField' (AmbiguousFieldOcc GhcPs) body) +-- (HsRecField' (FieldOcc GhcPs) body)) where +-- getAnnotationEntry = const NoEntryVal +-- exact (Left rbinds) = markAnnotated rbinds +-- exact (Right pbinds) = markAnnotated pbinds + +-- --------------------------------------------------------------------- +-- instance (ExactPrint body) +-- => ExactPrint +-- (Either [LocatedA (HsRecField' (AmbiguousFieldOcc GhcPs) body)] +-- [LocatedA (HsRecField' (FieldOcc GhcPs) body)]) where +-- getAnnotationEntry = const NoEntryVal +-- exact (Left rbinds) = markAnnotated rbinds +-- exact (Right pbinds) = markAnnotated pbinds + +-- --------------------------------------------------------------------- +instance -- (ExactPrint body) + (ExactPrint (HsRecField' (a GhcPs) body), + ExactPrint (HsRecField' (b GhcPs) body)) + => ExactPrint + (Either [LocatedA (HsRecField' (a GhcPs) body)] + [LocatedA (HsRecField' (b GhcPs) body)]) where + getAnnotationEntry = const NoEntryVal + exact (Left rbinds) = markAnnotated rbinds + exact (Right pbinds) = markAnnotated pbinds + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldLabelStrings GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (FieldLabelStrings fs) = markAnnotated fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsFieldLabel GhcPs) where + getAnnotationEntry (HsFieldLabel an _) = fromAnn an + + exact (HsFieldLabel an fs) = do + markAnnKwM an afDot AnnDot + markAnnotated fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsTupArg GhcPs) where + getAnnotationEntry (Present an _) = fromAnn an + getAnnotationEntry (Missing an) = fromAnn an + + exact (Present _ e) = markAnnotated e + + exact (Missing ApiAnnNotUsed) = return () + exact (Missing _) = printStringAdvance "," + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmdTop GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (HsCmdTop _ cmd) = markAnnotated cmd + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmd GhcPs) where + getAnnotationEntry (HsCmdArrApp an _ _ _ _) = fromAnn an + getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an + getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an + getAnnotationEntry (HsCmdLam {}) = NoEntryVal + getAnnotationEntry (HsCmdPar an _) = fromAnn an + getAnnotationEntry (HsCmdCase an _ _) = fromAnn an + getAnnotationEntry (HsCmdLamCase an _) = fromAnn an + getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an + getAnnotationEntry (HsCmdLet an _ _) = fromAnn an + getAnnotationEntry (HsCmdDo an _) = fromAnn an + + +-- ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) +-- = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +-- ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) +-- = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +-- ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) +-- = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +-- ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) +-- = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + + exact (HsCmdArrApp an arr arg _o isRightToLeft) = do + if isRightToLeft + then do + markAnnotated arr + markKw (anns an) + markAnnotated arg + else do + markAnnotated arg + markKw (anns an) + markAnnotated arr +-- markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do +-- -- isRightToLeft True => right-to-left (f -< arg) +-- -- False => left-to-right (arg >- f) +-- if isRightToLeft +-- then do +-- markLocated e1 +-- case o of +-- GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail +-- GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail +-- else do +-- markLocated e2 +-- case o of +-- GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail +-- GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + +-- if isRightToLeft +-- then markLocated e2 +-- else markLocated e1 + + exact (HsCmdArrForm an e fixity _mf [arg1,arg2]) = do + markLocatedMAA an al_open + case fixity of + Infix -> do + markAnnotated arg1 + markAnnotated e + markAnnotated arg2 + Prefix -> do + markAnnotated e + markAnnotated arg1 + markAnnotated arg2 + markLocatedMAA an al_close +-- markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do +-- -- The AnnOpen should be marked for a prefix usage, not for a postfix one, +-- -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm + +-- let isPrefixOp = case fixity of +-- GHC.Infix -> False +-- GHC.Prefix -> True +-- when isPrefixOp $ mark GHC.AnnOpenB -- "(|" + +-- -- This may be an infix operation +-- applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) +-- (Set.singleton InfixOp) (Set.singleton InfixOp)) +-- (prepareListAnnotation [e] +-- ++ prepareListAnnotation cs) +-- when isPrefixOp $ mark GHC.AnnCloseB -- "|)" + +-- markAST _ (GHC.HsCmdApp _ e1 e2) = do +-- markLocated e1 +-- markLocated e2 + + exact (HsCmdLam _ match) = markAnnotated match +-- markAST l (GHC.HsCmdLam _ match) = do +-- setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match + + exact (HsCmdPar an e) = do + markOpeningParen an + markAnnotated e + markClosingParen an + + exact (HsCmdCase an e alts) = do + markAnnKw an hsCaseAnnCase AnnCase + markAnnotated e + markAnnKw an hsCaseAnnOf AnnOf + markApiAnn' an hsCaseAnnsRest AnnOpenC + markApiAnnAll an hsCaseAnnsRest AnnSemi + markAnnotated alts + markApiAnn' an hsCaseAnnsRest AnnCloseC + -- markApiAnn an AnnCase + -- markAnnotated e1 + -- markApiAnn an AnnOf + -- markApiAnn an AnnOpenC + -- markAnnotated matches + -- markApiAnn an AnnCloseC + +-- markAST l (GHC.HsCmdCase _ e1 matches) = do +-- mark GHC.AnnCase +-- markLocated e1 +-- mark GHC.AnnOf +-- markOptional GHC.AnnOpenC +-- setContext (Set.singleton CaseAlt) $ do +-- markMatchGroup l matches +-- markOptional GHC.AnnCloseC + +-- markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do +-- mark GHC.AnnIf +-- markLocated e1 +-- markOffset GHC.AnnSemi 0 +-- mark GHC.AnnThen +-- markLocated e2 +-- markOffset GHC.AnnSemi 1 +-- mark GHC.AnnElse +-- markLocated e3 + +-- markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do +-- mark GHC.AnnLet +-- markOptional GHC.AnnOpenC +-- markLocalBindsWithLayout binds +-- markOptional GHC.AnnCloseC +-- mark GHC.AnnIn +-- markLocated e + + exact (HsCmdDo an es) = do + debugM $ "HsCmdDo" + markApiAnn' an al_rest AnnDo + markAnnotated es + +-- markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do +-- mark GHC.AnnDo +-- markOptional GHC.AnnOpenC +-- markListWithLayout es +-- markOptional GHC.AnnCloseC + +-- markAST _ (GHC.HsCmdWrap {}) = +-- traceM "warning: HsCmdWrap introduced after renaming" + +-- markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showPprUnsafe x + + exact x = error $ "exact HsCmd for:" ++ showAst x + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (CmdLStmt GhcPs) where +-- getAnnotationEntry = const NoEntryVal +-- exact (L _ a) = markAnnotated a + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (StmtLR GhcPs GhcPs (LHsCmd GhcPs)) where +instance (ExactPrint (LocatedA body)) + => ExactPrint (StmtLR GhcPs GhcPs (LocatedA body)) where +-- instance ExactPrint (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (BindStmt an _ _) = fromAnn an + getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal + getAnnotationEntry (BodyStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (LetStmt an _) = fromAnn an + getAnnotationEntry (ParStmt _ _ _ _) = NoEntryVal + getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an + getAnnotationEntry (RecStmt an _ _ _ _ _ _) = fromAnn an + + ----------------------------------------------------------------- + + exact (LastStmt _ body _ _) = do + debugM $ "LastStmt" + markAnnotated body + + exact (BindStmt an pat body) = do + debugM $ "BindStmt" + markAnnotated pat + markApiAnn an AnnLarrow + markAnnotated body + + exact (ApplicativeStmt _ _body _) = do + debugM $ "ApplicativeStmt" + -- TODO: ApplicativeStmt + -- markAnnotated body + error $ "need to complete ApplicativeStmt" + + exact (BodyStmt _ body _ _) = do + debugM $ "BodyStmt" + markAnnotated body + + exact (LetStmt an binds) = do + debugM $ "LetStmt" + markApiAnn an AnnLet + markAnnotated binds + + exact (ParStmt _ pbs _ _) = do + debugM $ "ParStmt" + markAnnotated pbs + + -- markAST l (GHC.ParStmt _ pbs _ _) = do + -- -- Within a given parallel list comprehension,one of the sections to be done + -- -- in parallel. It is a normal list comprehension, so has a list of + -- -- ParStmtBlock, one for each part of the sub- list comprehension + + + -- ifInContext (Set.singleton Intercalate) + -- ( + + -- unsetContext Intercalate $ + -- markListWithContextsFunction + -- (LC (Set.singleton Intercalate) -- only + -- Set.empty -- first + -- Set.empty -- middle + -- (Set.singleton Intercalate) -- last + -- ) (markAST l) pbs + -- ) + -- ( + -- unsetContext Intercalate $ + -- markListWithContextsFunction + -- (LC Set.empty -- only + -- (Set.fromList [AddVbar]) -- first + -- (Set.fromList [AddVbar]) -- middle + -- Set.empty -- last + -- ) (markAST l) pbs + -- ) + -- markTrailingSemi + + +-- pprStmt (TransStmt { trS_stmts = stmts, trS_by = by +-- , trS_using = using, trS_form = form }) +-- = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + + exact (TransStmt an form stmts _b using by _ _ _) = do + debugM $ "TransStmt" + markAnnotated stmts + exactTransStmt an by using form + + -- markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do + -- setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts + -- case form of + -- GHC.ThenForm -> do + -- mark GHC.AnnThen + -- unsetContext Intercalate $ markLocated using + -- case by of + -- Just b -> do + -- mark GHC.AnnBy + -- unsetContext Intercalate $ markLocated b + -- Nothing -> return () + -- GHC.GroupForm -> do + -- mark GHC.AnnThen + -- mark GHC.AnnGroup + -- case by of + -- Just b -> mark GHC.AnnBy >> markLocated b + -- Nothing -> return () + -- mark GHC.AnnUsing + -- markLocated using + -- inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + -- markTrailingSemi + + exact (RecStmt _ _stmts _ _ _ _ _) = do + -- TODO: implement RecStmt + debugM $ "RecStmt" + error $ "need to test RecStmt" + + -- markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do + -- mark GHC.AnnRec + -- markOptional GHC.AnnOpenC + -- markInside GHC.AnnSemi + -- markListWithLayout stmts + -- markOptional GHC.AnnCloseC + -- inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + -- markTrailingSemi + + -- exact x = error $ "exact CmdLStmt for:" ++ showAst x + -- exact x = error $ "exact CmdLStmt for:" + + +-- --------------------------------------------------------------------- + +instance ExactPrint (ParStmtBlock GhcPs GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (ParStmtBlock _ stmts _ _) = markAnnotated stmts + +exactTransStmt :: ApiAnn -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP () +exactTransStmt an by using ThenForm = do + debugM $ "exactTransStmt:ThenForm" + markApiAnn an AnnThen + markAnnotated using + case by of + Nothing -> return () + Just b -> do + markApiAnn an AnnBy + markAnnotated b +exactTransStmt an by using GroupForm = do + debugM $ "exactTransStmt:GroupForm" + markApiAnn an AnnThen + markApiAnn an AnnGroup + case by of + Just b -> do + markApiAnn an AnnBy + markAnnotated b + Nothing -> return () + markApiAnn an AnnUsing + markAnnotated using + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyClDecl GhcPs) where + getAnnotationEntry (FamDecl { }) = NoEntryVal + getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an + getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an + getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an + + exact (FamDecl _ decl) = do + markAnnotated decl + + exact (SynDecl { tcdSExt = an + , tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdRhs = rhs }) = do + -- There may be arbitrary parens around parts of the constructor that are + -- infix. + -- Turn these into comments so that they feed into the right place automatically + -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + markApiAnn an AnnType + + -- markTyClass Nothing fixity ln tyvars + exactVanillaDeclHead an ltycon tyvars fixity Nothing + markApiAnn an AnnEqual + markAnnotated rhs + + -- ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + -- , tcdRhs = rhs }) + -- = hang (text "type" <+> + -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals) + -- 4 (ppr rhs) +-- {- +-- SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs +-- , tcdLName :: Located (IdP pass) -- ^ Type constructor +-- , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an +-- -- associated type these +-- -- include outer binders +-- , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration +-- , tcdRhs :: LHsType pass } -- ^ RHS of type declaration + +-- -} +-- markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = do +-- -- There may be arbitrary parens around parts of the constructor that are +-- -- infix. +-- -- Turn these into comments so that they feed into the right place automatically +-- -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] +-- mark GHC.AnnType + +-- markTyClass Nothing fixity ln tyvars +-- mark GHC.AnnEqual +-- markLocated typ +-- markTrailingSemi + + exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars + , tcdFixity = fixity, tcdDataDefn = defn }) = + exactDataDefn an (exactVanillaDeclHead an ltycon tyvars fixity) defn + + -- ----------------------------------- + + exact (ClassDecl {tcdCExt = (an, sortKey, _), + tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = _docs}) + -- TODO: add a test that demonstrates tcdDocs + | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part + = top_matter + + | otherwise -- Laid out + = do + top_matter + -- markApiAnn an AnnWhere + markApiAnn an AnnOpenC + withSortKey sortKey + (prepareListAnnotationA sigs + ++ prepareListAnnotationA (bagToList methods) + ++ prepareListAnnotationA ats + ++ prepareListAnnotationA at_defs + -- ++ prepareListAnnotation docs + ) + markApiAnn an AnnCloseC + where + top_matter = do + annotationsToComments (apiAnnAnns an) [AnnOpenP, AnnCloseP] + markApiAnn an AnnClass + exactVanillaDeclHead an lclas tyvars fixity context + unless (null fds) $ do + markApiAnn an AnnVbar + markAnnotated fds + markApiAnn an AnnWhere + +-- -- ----------------------------------- + +-- markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds +-- sigs meths ats atdefs docs) = do +-- mark GHC.AnnClass +-- markLocated ctx + +-- markTyClass Nothing fixity ln tyVars + +-- unless (null fds) $ do +-- mark GHC.AnnVbar +-- markListIntercalateWithFunLevel markLocated 2 fds +-- mark GHC.AnnWhere +-- markOptional GHC.AnnOpenC -- '{' +-- markInside GHC.AnnSemi +-- -- AZ:TODO: we end up with both the tyVars and the following body of the +-- -- class defn in annSortKey for the class. This could cause problems when +-- -- changing things. +-- setContext (Set.singleton InClassDecl) $ +-- applyListAnnotationsLayout +-- (prepareListAnnotation sigs +-- ++ prepareListAnnotation (GHC.bagToList meths) +-- ++ prepareListAnnotation ats +-- ++ prepareListAnnotation atdefs +-- ++ prepareListAnnotation docs +-- ) +-- markOptional GHC.AnnCloseC -- '}' +-- markTrailingSemi +-- {- +-- | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs +-- tcdCtxt :: LHsContext pass, -- ^ Context... +-- tcdLName :: Located (IdP pass), -- ^ Name of the class +-- tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables +-- tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration +-- tcdFDs :: [Located (FunDep (Located (IdP pass)))], +-- -- ^ Functional deps +-- tcdSigs :: [LSig pass], -- ^ Methods' signatures +-- tcdMeths :: LHsBinds pass, -- ^ Default methods +-- tcdATs :: [LFamilyDecl pass], -- ^ Associated types; +-- tcdATDefs :: [LTyFamDefltEqn pass], +-- -- ^ Associated type defaults +-- tcdDocs :: [LDocDecl] -- ^ Haddock docs +-- } + +-- -} + +-- markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) +-- = error "extension hit for TyClDecl" +-- markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) +-- = error "extension hit for TyClDecl" +-- markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) +-- = error "extension hit for TyClDecl" +-- markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) +-- = error "extension hit for TyClDecl" +-- markAST _ (GHC.XTyClDecl _) +-- = error "extension hit for TyClDecl" + -- exact x = error $ "exact TyClDecl for:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (FunDep GhcPs) where + getAnnotationEntry (FunDep an _ _) = fromAnn an + + exact (FunDep an ls rs') = do + markAnnotated ls + markApiAnn an AnnRarrow + markAnnotated rs' + +-- --------------------------------------------------------------------- + +instance ExactPrint (FamilyDecl GhcPs) where + getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an + + exact (FamilyDecl { fdExt = an + , fdInfo = info + , fdTopLevel = top_level + , fdLName = ltycon + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L _ result + , fdInjectivityAnn = mb_inj }) = do + -- = vcat [ pprFlavour info <+> pp_top_level <+> + -- pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> + -- pp_kind <+> pp_inj <+> pp_where + -- , nest 2 $ pp_eqns ] + exactFlavour an info + exact_top_level + exactVanillaDeclHead an ltycon tyvars fixity Nothing + exact_kind + mapM_ markAnnotated mb_inj + case info of + ClosedTypeFamily mb_eqns -> do + markApiAnn an AnnWhere + markApiAnn an AnnOpenC + case mb_eqns of + Nothing -> printStringAdvance ".." + Just eqns -> markAnnotated eqns + markApiAnn an AnnCloseC + _ -> return () + where + exact_top_level = case top_level of + TopLevel -> markApiAnn an AnnFamily + NotTopLevel -> return () + + exact_kind = case result of + NoSig _ -> return () + KindSig _ kind -> markApiAnn an AnnDcolon >> markAnnotated kind + TyVarSig _ tv_bndr -> markApiAnn an AnnEqual >> markAnnotated tv_bndr + + -- exact_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) + +exactFlavour :: ApiAnn -> FamilyInfo GhcPs -> EPP () +exactFlavour an DataFamily = markApiAnn an AnnData +exactFlavour an OpenTypeFamily = markApiAnn an AnnType +exactFlavour an (ClosedTypeFamily {}) = markApiAnn an AnnType + +-- instance Outputable (FamilyInfo pass) where +-- ppr info = pprFlavour info <+> text "family" + +-- --------------------------------------------------------------------- + +exactDataDefn :: ApiAnn + -> (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header + -> HsDataDefn GhcPs + -> EPP () +exactDataDefn an exactHdr + (HsDataDefn { dd_ext = an2 + , dd_ND = new_or_data, dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) = do + if new_or_data == DataType + then markApiAnn an2 AnnData + else markApiAnn an2 AnnNewtype + mapM_ markAnnotated mb_ct + exactHdr context + case mb_sig of + Nothing -> return () + Just kind -> do + markApiAnn an AnnDcolon + markAnnotated kind + when (isGadt condecls) $ markApiAnn an AnnWhere + exact_condecls an2 condecls + mapM_ markAnnotated derivings + return () + +exactVanillaDeclHead :: ApiAnn + -> LocatedN RdrName + -> LHsQTyVars GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EPP () +exactVanillaDeclHead an thing (HsQTvs { hsq_explicit = tyvars }) fixity context = do + let + exact_tyvars :: [LHsTyVarBndr () GhcPs] -> EPP () + exact_tyvars (varl:varsr) + | fixity == Infix && length varsr > 1 = do + -- = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) + -- , (ppr.unLoc) (head varsr), char ')' + -- , hsep (map (ppr.unLoc) (tail vaprsr))] + markApiAnnAll an id AnnOpenP + markAnnotated varl + markAnnotated thing + markAnnotated (head varsr) + markApiAnnAll an id AnnCloseP + markAnnotated (tail varsr) + return () + | fixity == Infix = do + -- = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) + -- , hsep (map (ppr.unLoc) varsr)] + markAnnotated varl + markAnnotated thing + markAnnotated varsr + return () + | otherwise = do + -- hsep [ pprPrefixOcc (unLoc thing) + -- , hsep (map (ppr.unLoc) (varl:varsr))] + markAnnotated thing + mapM_ markAnnotated (varl:varsr) + return () + exact_tyvars [] = do + -- pprPrefixOcc (unLoc thing) + markAnnotated thing + mapM_ markAnnotated context + exact_tyvars tyvars + +-- --------------------------------------------------------------------- + +instance ExactPrint (InjectivityAnn GhcPs) where + getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an + exact (InjectivityAnn an lhs rhs) = do + markApiAnn an AnnVbar + markAnnotated lhs + markApiAnn an AnnRarrow + mapM_ markAnnotated rhs + -- Just (L _ (InjectivityAnn _ lhs rhs)) -> + -- hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + -- Nothing -> empty + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (HsTyVarBndr () GhcPs) where +-- getAnnotationEntry (UserTyVar an _ _) = fromAnn an +-- getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an +-- exact = withPpr + +instance (Typeable flag) => ExactPrint (HsTyVarBndr flag GhcPs) where + getAnnotationEntry (UserTyVar an _ _) = fromAnn an + getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an + + exact (UserTyVar an _ n) = do + markApiAnnAll an id AnnOpenP + markAnnotated n + markApiAnnAll an id AnnCloseP + exact (KindedTyVar an _ n k) = do + markApiAnnAll an id AnnOpenP + markAnnotated n + markApiAnn an AnnDcolon + markAnnotated k + markApiAnnAll an id AnnCloseP + +-- --------------------------------------------------------------------- + +-- NOTE: this is also an alias for LHsKind +-- instance ExactPrint (LHsType GhcPs) where +-- getAnnotationEntry = entryFromLocatedA +-- exact (L _ a) = markAnnotated a + +instance ExactPrint (HsType GhcPs) where + getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal + getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal + getAnnotationEntry (HsTyVar an _ _) = fromAnn an + getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal + getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal + getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an + getAnnotationEntry (HsListTy an _) = fromAnn an + getAnnotationEntry (HsTupleTy an _ _) = fromAnn an + getAnnotationEntry (HsSumTy an _) = fromAnn an + getAnnotationEntry (HsOpTy _ _ _ _) = NoEntryVal + getAnnotationEntry (HsParTy an _) = fromAnn an + getAnnotationEntry (HsIParamTy an _ _) = fromAnn an + getAnnotationEntry (HsStarTy _ _) = NoEntryVal + getAnnotationEntry (HsKindSig an _ _) = fromAnn an + getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal + getAnnotationEntry (HsDocTy an _ _) = fromAnn an + getAnnotationEntry (HsBangTy an _ _) = fromAnn an + getAnnotationEntry (HsRecTy an _) = fromAnn an + getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an + getAnnotationEntry (HsExplicitTupleTy an _) = fromAnn an + getAnnotationEntry (HsTyLit _ _) = NoEntryVal + getAnnotationEntry (HsWildCardTy _) = NoEntryVal + getAnnotationEntry (XHsType _) = NoEntryVal + + + exact (HsForAllTy { hst_xforall = _an + , hst_tele = tele, hst_body = ty }) = do + markAnnotated tele + markAnnotated ty + + exact (HsQualTy _ ctxt ty) = do + markAnnotated ctxt + -- markApiAnn an AnnDarrow + markAnnotated ty + exact (HsTyVar an promoted name) = do + when (promoted == IsPromoted) $ markApiAnn an AnnSimpleQuote + markAnnotated name + + exact (HsAppTy _ t1 t2) = markAnnotated t1 >> markAnnotated t2 + exact (HsAppKindTy ss ty ki) = do + markAnnotated ty + printStringAtSs ss "@" + markAnnotated ki + exact (HsFunTy an mult ty1 ty2) = do + markAnnotated ty1 + markArrow an mult + markAnnotated ty2 + exact (HsListTy an tys) = do + markOpeningParen an + markAnnotated tys + markClosingParen an + exact (HsTupleTy an _con tys) = do + markOpeningParen an + markAnnotated tys + markClosingParen an + exact (HsSumTy an tys) = do + markOpeningParen an + markAnnotated tys + markClosingParen an + exact (HsOpTy _an t1 lo t2) = do + markAnnotated t1 + markAnnotated lo + markAnnotated t2 + exact (HsParTy an ty) = do + markOpeningParen an + markAnnotated ty + markClosingParen an + exact (HsIParamTy an n t) = do + markAnnotated n + markApiAnn an AnnDcolon + markAnnotated t + exact (HsStarTy _an isUnicode) + = if isUnicode + then printStringAdvance "\x2605" -- Unicode star + else printStringAdvance "*" + exact (HsKindSig an ty k) = do + exact ty + markApiAnn an AnnDcolon + exact k + exact (HsSpliceTy _ splice) = do + markAnnotated splice + -- exact x@(HsDocTy an _ _) = withPpr x + exact (HsBangTy an (HsSrcBang mt _up str) ty) = do + case mt of + NoSourceText -> return () + SourceText src -> do + debugM $ "HsBangTy: src=" ++ showAst src + markLocatedAALS an id AnnOpen (Just src) + markLocatedAALS an id AnnClose (Just "#-}") + debugM $ "HsBangTy: done unpackedness" + case str of + SrcLazy -> markApiAnn an AnnTilde + SrcStrict -> markApiAnn an AnnBang + NoSrcStrict -> return () + markAnnotated ty + -- exact x@(HsRecTy an _) = withPpr x + exact (HsExplicitListTy an prom tys) = do + when (isPromoted prom) $ markApiAnn an AnnSimpleQuote + markApiAnn an AnnOpenS + markAnnotated tys + markApiAnn an AnnCloseS + exact (HsExplicitTupleTy an tys) = do + markApiAnn an AnnSimpleQuote + markApiAnn an AnnOpenP + markAnnotated tys + markApiAnn an AnnCloseP + exact (HsTyLit _ lit) = do + case lit of + (HsNumTy src v) -> printSourceText src (show v) + (HsStrTy src v) -> printSourceText src (show v) + (HsCharTy src v) -> printSourceText src (show v) + exact (HsWildCardTy _) = printStringAdvance "_" + exact x = error $ "missing match for HsType:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsForAllTelescope GhcPs) where + getAnnotationEntry (HsForAllVis an _) = fromAnn an + getAnnotationEntry (HsForAllInvis an _) = fromAnn an + + exact (HsForAllVis an bndrs) = do + markLocatedAA an fst -- AnnForall + markAnnotated bndrs + markLocatedAA an snd -- AnnRarrow + + exact (HsForAllInvis an bndrs) = do + markLocatedAA an fst -- AnnForall + markAnnotated bndrs + markLocatedAA an snd -- AnnDot + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDerivingClause GhcPs) where + getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d) + + exact (HsDerivingClause { deriv_clause_ext = an + , deriv_clause_strategy = dcs + , deriv_clause_tys = dct }) = do + -- = hsep [ text "deriving" + -- , pp_strat_before + -- , pp_dct dct + -- , pp_strat_after ] + markApiAnn an AnnDeriving + exact_strat_before + markAnnotated dct + exact_strat_after + where + -- -- This complexity is to distinguish between + -- -- deriving Show + -- -- deriving (Show) + -- pp_dct [HsIB { hsib_body = ty }] + -- = ppr (parenthesizeHsType appPrec ty) + -- pp_dct _ = parens (interpp'SP dct) + + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (exact_strat_before, exact_strat_after) = + case dcs of + Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v) + _ -> (mapM_ markAnnotated dcs, pure ()) + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivStrategy GhcPs) where + getAnnotationEntry (StockStrategy an) = fromAnn an + getAnnotationEntry (AnyclassStrategy an) = fromAnn an + getAnnotationEntry (NewtypeStrategy an) = fromAnn an + getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an + + exact (StockStrategy an) = markApiAnn an AnnStock + exact (AnyclassStrategy an) = markApiAnn an AnnAnyclass + exact (NewtypeStrategy an) = markApiAnn an AnnNewtype + exact (ViaStrategy (XViaStrategyPs an ty)) + = markApiAnn an AnnVia >> markAnnotated ty + +-- --------------------------------------------------------------------- + +instance (ExactPrint a) => ExactPrint (LocatedC a) where + getAnnotationEntry (L sann _) = fromAnn sann + + exact (L (SrcSpanAnn ApiAnnNotUsed _) a) = markAnnotated a + exact (L (SrcSpanAnn (ApiAnn _ (AnnContext ma opens closes) _) _) a) = do + -- case ma of + -- Just (UnicodeSyntax, rs) -> markKw' AnnDarrowU rs + -- Just (NormalSyntax, rs) -> markKw' AnnDarrow rs + -- Nothing -> pure () + mapM_ (markKwA AnnOpenP) (sort opens) + markAnnotated a + mapM_ (markKwA AnnCloseP) (sort closes) + case ma of + Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r + Just (NormalSyntax, r) -> markKwA AnnDarrow r + Nothing -> pure () + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivClauseTys GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (DctSingle _ ty) = markAnnotated ty + exact (DctMulti _ tys) = do + -- parens (interpp'SP tys) + markAnnotated tys + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (HsSig _ bndrs ty) = do + markAnnotated bndrs + markAnnotated ty + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedN RdrName) where + getAnnotationEntry (L sann _) = fromAnn sann + + exact (L (SrcSpanAnn ApiAnnNotUsed l) n) = do + p <- getPosP + debugM $ "LocatedN RdrName:NOANN: (p,l,str)=" ++ show (p,ss2range l, showPprUnsafe n) + printStringAtSs l (showPprUnsafe n) + exact (L (SrcSpanAnn (ApiAnn _anchor ann _cs) _ll) n) = do + case ann of + NameAnn a o l c t -> do + markName a o (Just (l,n)) c + markTrailing t + NameAnnCommas a o cs c t -> do + let (kwo,kwc) = adornments a + markKw (AddApiAnn kwo o) + forM_ cs (\loc -> markKw (AddApiAnn AnnComma loc)) + markKw (AddApiAnn kwc c) + markTrailing t + NameAnnOnly a o c t -> do + markName a o Nothing c + markTrailing t + NameAnnRArrow nl t -> do + markKw (AddApiAnn AnnRarrow nl) + markTrailing t + NameAnnQuote q name t -> do + debugM $ "NameAnnQuote" + markKw (AddApiAnn AnnSimpleQuote q) + markAnnotated (L name n) + markTrailing t + NameAnnTrailing t -> do + printStringAdvance (showPprUnsafe n) + markTrailing t + +markName :: NameAdornment + -> AnnAnchor -> Maybe (AnnAnchor,RdrName) -> AnnAnchor -> EPP () +markName adorn open mname close = do + let (kwo,kwc) = adornments adorn + markKw (AddApiAnn kwo open) + case mname of + Nothing -> return () + Just (name, a) -> printStringAtAA name (showPprUnsafe a) + markKw (AddApiAnn kwc close) + +adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId) +adornments NameParens = (AnnOpenP, AnnCloseP) +adornments NameParensHash = (AnnOpenPH, AnnClosePH) +adornments NameBackquotes = (AnnBackquote, AnnBackquote) +adornments NameSquare = (AnnOpenS, AnnCloseS) + +markTrailing :: [TrailingAnn] -> EPP () +markTrailing ts = do + p <- getPosP + debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) + mapM_ markKwT (sort ts) + +-- --------------------------------------------------------------------- + +-- based on pp_condecls in Decls.hs +exact_condecls :: ApiAnn -> [LConDecl GhcPs] -> EPP () +exact_condecls an cs + | gadt_syntax -- In GADT syntax + -- = hang (text "where") 2 (vcat (map ppr cs)) + = do + -- printStringAdvance "exact_condecls:gadt" + mapM_ markAnnotated cs + | otherwise -- In H98 syntax + -- = equals <+> sep (punctuate (text " |") (map ppr cs)) + = do + -- printStringAdvance "exact_condecls:not gadt" + markApiAnn an AnnEqual + mapM_ markAnnotated cs + where + gadt_syntax = case cs of + [] -> False + (L _ ConDeclH98{} : _) -> False + (L _ ConDeclGADT{} : _) -> True + +-- --------------------------------------------------------------------- + +instance ExactPrint (ConDecl GhcPs) where + getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x) + getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x) + +-- based on pprConDecl + exact (ConDeclH98 { con_ext = an + , con_name = con + , con_forall = has_forall + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) = do + -- = sep [ ppr_mbDoc doc + -- , pprHsForAll (mkHsForAllInvisTele ex_tvs) mcxt + -- , ppr_details args ] + mapM_ markAnnotated doc + when has_forall $ markApiAnn an AnnForall + mapM_ markAnnotated ex_tvs + when has_forall $ markApiAnn an AnnDot + -- exactHsForall (mkHsForAllInvisTele ex_tvs) mcxt + mapM_ markAnnotated mcxt + when (isJust mcxt) $ markApiAnn an AnnDarrow + + exact_details args + + -- case args of + -- InfixCon _ _ -> return () + -- _ -> markAnnotated con + where + -- -- In ppr_details: let's not print the multiplicities (they are always 1, by + -- -- definition) as they do not appear in an actual declaration. + exact_details (InfixCon t1 t2) = do + markAnnotated t1 + markAnnotated con + markAnnotated t2 + exact_details (PrefixCon tyargs tys) = do + markAnnotated con + markAnnotated tyargs + markAnnotated tys + exact_details (RecCon fields) = do + markAnnotated con + markAnnotated fields + + -- ----------------------------------- + + exact (ConDeclGADT { con_g_ext = an + , con_names = cons + , con_bndrs = bndrs + , con_mb_cxt = mcxt, con_g_args = args + , con_res_ty = res_ty, con_doc = doc }) = do + mapM_ markAnnotated doc + mapM_ markAnnotated cons + markApiAnn an AnnDcolon + annotationsToComments (apiAnnAnns an) [AnnOpenP, AnnCloseP] + -- when has_forall $ markApiAnn an AnnForall + markAnnotated bndrs + -- mapM_ markAnnotated qvars + -- when has_forall $ markApiAnn an AnnDot + mapM_ markAnnotated mcxt + when (isJust mcxt) $ markApiAnn an AnnDarrow + -- mapM_ markAnnotated args + case args of + (PrefixConGADT args') -> mapM_ markAnnotated args' + (RecConGADT fields) -> markAnnotated fields + -- mapM_ markAnnotated (unLoc fields) + markAnnotated res_ty + -- markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do + -- setContext (Set.singleton PrefixOp) $ markListIntercalate lns + -- mark GHC.AnnDcolon + -- annotationsToComments [GHC.AnnOpenP] + -- markLocated (GHC.L l (ResTyGADTHook forall qvars)) + -- markMaybe mbCxt + -- markHsConDeclDetails False True lns args + -- markLocated typ + -- markManyOptional GHC.AnnCloseP + -- markTrailingSemi + +-- pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars +-- , con_mb_cxt = mcxt, con_args = args +-- , con_res_ty = res_ty, con_doc = doc }) +-- = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon +-- <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) mcxt, +-- ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) +-- where +-- get_args (PrefixCon args) = map ppr args +-- get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] +-- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr_con_names cons) + +-- ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) +-- ppr_arrow_chain [] = empty + +-- ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc +-- ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) + + +-- --------------------------------------------------------------------- + +-- exactHsForall :: HsForAllTelescope GhcPs +-- -> Maybe (LHsContext GhcPs) -> EPP () +-- exactHsForall = exactHsForAllExtra False + +-- exactHsForAllExtra :: Bool +-- -> HsForAllTelescope GhcPs +-- -> Maybe (LHsContext GhcPs) -> EPP () +-- exactHsForAllExtra show_extra Nothing = return () +-- exactHsForAllExtra show_extra lctxt@(Just ctxt) +-- | not show_extra = markAnnotated ctxt +-- -- | null ctxt = char '_' <+> darrow +-- | null ctxt = return () +-- | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow +-- where +-- ctxt' = map ppr ctxt ++ [char '_'] + +-- --------------------------------------------------------------------- + +instance ExactPrint Void where + getAnnotationEntry = const NoEntryVal + exact _ = return () + +-- --------------------------------------------------------------------- + +instance (Typeable flag) => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where + getAnnotationEntry (HsOuterImplicit _) = NoEntryVal + getAnnotationEntry (HsOuterExplicit an _) = fromAnn an + + exact (HsOuterImplicit _) = pure () + exact (HsOuterExplicit an bndrs) = do + markLocatedAA an fst -- "forall" + markAnnotated bndrs + markLocatedAA an snd -- "." + +-- --------------------------------------------------------------------- + +instance ExactPrint (ConDeclField GhcPs) where + getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f) + + exact (ConDeclField an names ftype mdoc) = do + markAnnotated names + markApiAnn an AnnDcolon + markAnnotated ftype + mapM_ markAnnotated mdoc + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldOcc GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (FieldOcc _ n) = markAnnotated n + +-- --------------------------------------------------------------------- + +instance ExactPrint (AmbiguousFieldOcc GhcPs) where + getAnnotationEntry = const NoEntryVal + exact (Unambiguous _ n) = markAnnotated n + exact (Ambiguous _ n) = markAnnotated n + +-- --------------------------------------------------------------------- + +instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where + getAnnotationEntry = const NoEntryVal + exact (HsScaled _arr t) = markAnnotated t + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (LHsContext GhcPs) where +-- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann +-- exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP CType) where + getAnnotationEntry = entryFromLocatedA + + exact (L (SrcSpanAnn ApiAnnNotUsed _) ct) = withPpr ct + exact (L (SrcSpanAnn an _ll) + (CType stp mh (stct,ct))) = do + markAnnOpenP an stp "{-# CTYPE" + case mh of + Nothing -> return () + Just (Header srcH _h) -> + markLocatedAALS an apr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" "")) + markLocatedAALS an apr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) "")) + markAnnCloseP an + +-- instance Annotate GHC.CType where +-- markAST _ (GHC.CType src mh f) = do +-- -- markWithString GHC.AnnOpen src +-- markAnnOpen src "" +-- case mh of +-- Nothing -> return () +-- Just (GHC.Header srcH _h) -> +-- -- markWithString GHC.AnnHeader srcH +-- markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") +-- -- markWithString GHC.AnnVal (fst f) +-- markSourceText (fst f) (GHC.unpackFS $ snd f) +-- markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance ExactPrint (SourceText, RuleName) where + -- We end up at the right place from the Located wrapper + getAnnotationEntry = const NoEntryVal + + exact (st, rn) + = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") + + +-- ===================================================================== +-- LocatedL instances start -- +-- +-- Each is dealt with specifically, as they have +-- different wrapping annotations in the al_rest zone. +-- +-- In future, the annotation could perhaps be improved, with an +-- 'al_pre' and 'al_post' set of annotations to be simply sorted and +-- applied. +-- --------------------------------------------------------------------- + +-- instance (ExactPrint body) => ExactPrint (LocatedL body) where +-- getAnnotationEntry = entryFromLocatedA +-- exact (L (SrcSpanAnn an _) b) = do +-- markLocatedMAA an al_open +-- markApiAnnAll an al_rest AnnSemi +-- markAnnotated b +-- markLocatedMAA an al_close + +instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + + exact (L (SrcSpanAnn ann _) ies) = do + debugM $ "LocatedL [LIE" + markLocatedAAL ann al_rest AnnHiding + p <- getPosP + debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p + markAnnList ann (markAnnotated ies) + +-- AZ:TODO: combine with next instance +instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + exact (L la a) = do + debugM $ "LocatedL [LMatch" + -- TODO: markAnnList? + markApiAnnAll (ann la) al_rest AnnWhere + markLocatedMAA (ann la) al_open + markApiAnnAll (ann la) al_rest AnnSemi + markAnnotated a + markLocatedMAA (ann la) al_close + +instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsCmd GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + exact (L la a) = do + debugM $ "LocatedL [LMatch" + -- TODO: markAnnList? + markApiAnnAll (ann la) al_rest AnnWhere + markLocatedMAA (ann la) al_open + markApiAnnAll (ann la) al_rest AnnSemi + markAnnotated a + markLocatedMAA (ann la) al_close + +-- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where +instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn an _) stmts) = do + debugM $ "LocatedL [ExprLStmt" + markAnnList an $ do + -- markLocatedMAA an al_open + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + markAnnotated ls + markAnnotated initStmts + _ -> markAnnotated stmts + -- x -> error $ "pprDo:ListComp" ++ showAst x + -- markLocatedMAA an al_close + +-- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where +instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn ann _) es) = do + debugM $ "LocatedL [CmdLStmt" + markLocatedMAA ann al_open + mapM_ markAnnotated es + markLocatedMAA ann al_close + +instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn an _) fs) = do + debugM $ "LocatedL [LConDeclField" + markAnnList an (mapM_ markAnnotated fs) -- AZ:TODO get rid of mapM_ + +instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where + getAnnotationEntry = entryFromLocatedA + exact (L (SrcSpanAnn an _) bf) = do + debugM $ "LocatedL [LBooleanFormula" + markAnnList an (markAnnotated bf) + +-- --------------------------------------------------------------------- +-- LocatedL instances end -- +-- ===================================================================== + +instance ExactPrint (IE GhcPs) where + getAnnotationEntry (IEVar _ _) = NoEntryVal + getAnnotationEntry (IEThingAbs an _) = fromAnn an + getAnnotationEntry (IEThingAll an _) = fromAnn an + getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an + getAnnotationEntry (IEModuleContents an _)= fromAnn an + getAnnotationEntry (IEGroup _ _ _) = NoEntryVal + getAnnotationEntry (IEDoc _ _) = NoEntryVal + getAnnotationEntry (IEDocNamed _ _) = NoEntryVal + + exact (IEVar _ ln) = markAnnotated ln + exact (IEThingAbs _ thing) = markAnnotated thing + exact (IEThingAll an thing) = do + markAnnotated thing + markApiAnn an AnnOpenP + markApiAnn an AnnDotdot + markApiAnn an AnnCloseP + + exact (IEThingWith an thing wc withs) = do + markAnnotated thing + markApiAnn an AnnOpenP + case wc of + NoIEWildcard -> markAnnotated withs + IEWildcard pos -> do + let (bs, as) = splitAt pos withs + markAnnotated bs + markApiAnn an AnnDotdot + markApiAnn an AnnComma + markAnnotated as + markApiAnn an AnnCloseP + + exact (IEModuleContents an (L lm mn)) = do + markApiAnn an AnnModule + printStringAtSs lm (moduleNameString mn) + + -- exact (IEGroup _ _ _) = NoEntryVal + -- exact (IEDoc _ _) = NoEntryVal + -- exact (IEDocNamed _ _) = NoEntryVal + exact x = error $ "missing match for IE:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (IEWrappedName RdrName) where + getAnnotationEntry = const NoEntryVal + + exact (IEName n) = markAnnotated n + exact (IEPattern r n) = do + printStringAtAA r "pattern" + markAnnotated n + exact (IEType r n) = do + printStringAtAA r "type" + markAnnotated n + +-- markIEWrapped :: ApiAnn -> LIEWrappedName RdrName -> EPP () +-- markIEWrapped an (L _ (IEName n)) +-- = markAnnotated n +-- markIEWrapped an (L _ (IEPattern n)) +-- = markApiAnn an AnnPattern >> markAnnotated n +-- markIEWrapped an (L _ (IEType n)) +-- = markApiAnn an AnnType >> markAnnotated n + +-- --------------------------------------------------------------------- + +-- instance ExactPrint (LocatedA (Pat GhcPs)) where +-- -- getAnnotationEntry (L (SrcSpanAnn ann _) _) = fromAnn ann +-- getAnnotationEntry = entryFromLocatedA +-- exact (L _ a) = do +-- debugM $ "exact:LPat:" ++ showPprUnsafe a +-- markAnnotated a + +instance ExactPrint (Pat GhcPs) where + getAnnotationEntry (WildPat _) = NoEntryVal + getAnnotationEntry (VarPat _ _) = NoEntryVal + getAnnotationEntry (LazyPat an _) = fromAnn an + getAnnotationEntry (AsPat an _ _) = fromAnn an + getAnnotationEntry (ParPat an _) = fromAnn an + getAnnotationEntry (BangPat an _) = fromAnn an + getAnnotationEntry (ListPat an _) = fromAnn an + getAnnotationEntry (TuplePat an _ _) = fromAnn an + getAnnotationEntry (SumPat an _ _ _) = fromAnn an + getAnnotationEntry (ConPat an _ _) = fromAnn an + getAnnotationEntry (ViewPat an _ _) = fromAnn an + getAnnotationEntry (SplicePat _ _) = NoEntryVal + getAnnotationEntry (LitPat _ _) = NoEntryVal + getAnnotationEntry (NPat an _ _ _) = fromAnn an + getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an + getAnnotationEntry (SigPat an _ _) = fromAnn an + + exact (WildPat _) = do + anchor <- getAnchorU + debugM $ "WildPat:anchor=" ++ show anchor + printStringAtRs anchor "_" + exact (VarPat _ n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered. + let pun_RDR = "pun-right-hand-side" + when (showPprUnsafe n /= pun_RDR) $ markAnnotated n + -- | LazyPat an pat) + exact (AsPat an n pat) = do + markAnnotated n + markApiAnn an AnnAt + markAnnotated pat + exact (ParPat an pat) = do + markAnnKw an ap_open AnnOpenP + markAnnotated pat + markAnnKw an ap_close AnnCloseP + + -- | BangPat an pat) + exact (ListPat an pats) = markAnnList an (markAnnotated pats) + + exact (TuplePat an pats boxity) = do + case boxity of + Boxed -> markApiAnn an AnnOpenP + Unboxed -> markApiAnn an AnnOpenPH + markAnnotated pats + case boxity of + Boxed -> markApiAnn an AnnCloseP + Unboxed -> markApiAnn an AnnClosePH + + exact (SumPat an pat _alt _arity) = do + markLocatedAAL an sumPatParens AnnOpenPH + markAnnKwAll an sumPatVbarsBefore AnnVbar + markAnnotated pat + markAnnKwAll an sumPatVbarsAfter AnnVbar + markLocatedAAL an sumPatParens AnnClosePH + -- markPat _ (GHC.SumPat _ pat alt arity) = do + -- markWithString GHC.AnnOpen "(#" + -- replicateM_ (alt - 1) $ mark GHC.AnnVbar + -- markLocated pat + -- replicateM_ (arity - alt) $ mark GHC.AnnVbar + -- markWithString GHC.AnnClose "#)" + + -- | ConPat an con args) + exact (ConPat an con details) = exactUserCon an con details + exact (ViewPat an expr pat) = do + markAnnotated expr + markApiAnn an AnnRarrow + markAnnotated pat + exact (SplicePat _ splice) = markAnnotated splice + exact (LitPat _ lit) = printStringAdvance (hsLit2String lit) + exact (NPat an ol mn _) = do + when (isJust mn) $ markApiAnn an AnnMinus + markAnnotated ol + + -- | NPlusKPat an n lit1 lit2 _ _) + exact (SigPat an pat sig) = do + markAnnotated pat + markApiAnn an AnnDcolon + markAnnotated sig + -- exact x = withPpr x + exact x = error $ "missing match for Pat:" ++ showAst x + +-- instance Annotate (GHC.Pat GHC.GhcPs) where +-- markAST loc typ = do +-- markPat loc typ +-- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") +-- where +-- markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" +-- markPat l (GHC.VarPat _ n) = do +-- -- The parser inserts a placeholder value for a record pun rhs. This must be +-- -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is +-- -- resolved, particularly for pretty printing where annotations are added. +-- let pun_RDR = "pun-right-hand-side" +-- when (showPprUnsafe n /= pun_RDR) $ +-- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) +-- -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n +-- markPat _ (GHC.LazyPat _ p) = do +-- mark GHC.AnnTilde +-- markLocated p + +-- markPat _ (GHC.AsPat _ ln p) = do +-- markLocated ln +-- mark GHC.AnnAt +-- markLocated p + +-- markPat _ (GHC.ParPat _ p) = do +-- mark GHC.AnnOpenP +-- markLocated p +-- mark GHC.AnnCloseP + +-- markPat _ (GHC.BangPat _ p) = do +-- mark GHC.AnnBang +-- markLocated p + +-- markPat _ (GHC.ListPat _ ps) = do +-- mark GHC.AnnOpenS +-- markListIntercalateWithFunLevel markLocated 2 ps +-- mark GHC.AnnCloseS + +-- markPat _ (GHC.TuplePat _ pats b) = do +-- if b == GHC.Boxed then mark GHC.AnnOpenP +-- else markWithString GHC.AnnOpen "(#" +-- markListIntercalateWithFunLevel markLocated 2 pats +-- if b == GHC.Boxed then mark GHC.AnnCloseP +-- else markWithString GHC.AnnClose "#)" + +-- markPat _ (GHC.SumPat _ pat alt arity) = do +-- markWithString GHC.AnnOpen "(#" +-- replicateM_ (alt - 1) $ mark GHC.AnnVbar +-- markLocated pat +-- replicateM_ (arity - alt) $ mark GHC.AnnVbar +-- markWithString GHC.AnnClose "#)" + +-- markPat _ (GHC.ConPatIn n dets) = do +-- markHsConPatDetails n dets + +-- markPat _ GHC.ConPatOut {} = +-- traceM "warning: ConPatOut Introduced after renaming" + +-- markPat _ (GHC.ViewPat _ e pat) = do +-- markLocated e +-- mark GHC.AnnRarrow +-- markLocated pat + +-- markPat l (GHC.SplicePat _ s) = do +-- markAST l s + +-- markPat l (GHC.LitPat _ lp) = markAST l lp + +-- markPat _ (GHC.NPat _ ol mn _) = do +-- when (isJust mn) $ mark GHC.AnnMinus +-- markLocated ol + +-- markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do +-- markLocated ln +-- markWithString GHC.AnnVal "+" -- "+" +-- markLocated ol + + +-- markPat _ (GHC.SigPat _ pat ty) = do +-- markLocated pat +-- mark GHC.AnnDcolon +-- markLHsSigWcType ty + +-- markPat _ GHC.CoPat {} = +-- traceM "warning: CoPat introduced after renaming" + +-- markPat _ (GHC.XPat (GHC.L l p)) = markPat l p +-- -- markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showPprUnsafe x + + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsPatSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact (HsPS _ ty) = markAnnotated ty + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsOverLit GhcPs) where + getAnnotationEntry = const NoEntryVal + + exact ol = + let str = case ol_val ol of + HsIntegral (IL src _ _) -> src + HsFractional (FL{ fl_text = src }) -> src + HsIsString src _ -> src + in + case str of + SourceText s -> printStringAdvance s + NoSourceText -> return () + +-- --------------------------------------------------------------------- + +hsLit2String :: HsLit GhcPs -> String +hsLit2String lit = + case lit of + HsChar src v -> toSourceTextWithSuffix src v "" + -- It should be included here + -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 + HsCharPrim src p -> toSourceTextWithSuffix src p "#" + HsString src v -> toSourceTextWithSuffix src v "" + HsStringPrim src v -> toSourceTextWithSuffix src v "" + HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" + HsIntPrim src v -> toSourceTextWithSuffix src v "" + HsWordPrim src v -> toSourceTextWithSuffix src v "" + HsInt64Prim src v -> toSourceTextWithSuffix src v "" + HsWord64Prim src v -> toSourceTextWithSuffix src v "" + HsInteger src v _ -> toSourceTextWithSuffix src v "" + HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" + HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" + HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" + -- (XLit x) -> error $ "got XLit for:" ++ showPprUnsafe x + +toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String +toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix +toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix + +sourceTextToString :: SourceText -> String -> String +sourceTextToString NoSourceText alt = alt +sourceTextToString (SourceText txt) _ = txt + +-- --------------------------------------------------------------------- + +exactUserCon :: (ExactPrint con) => ApiAnn -> con -> HsConPatDetails GhcPs -> EPP () +exactUserCon _ c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2 +exactUserCon an c details = do + markAnnotated c + markApiAnn an AnnOpenC + exactConArgs details + markApiAnn an AnnCloseC + + +exactConArgs ::HsConPatDetails GhcPs -> EPP () +exactConArgs (PrefixCon tyargs pats) = markAnnotated tyargs >> markAnnotated pats +exactConArgs (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated p2 +exactConArgs (RecCon rpats) = markAnnotated rpats + +-- --------------------------------------------------------------------- + +entryFromLocatedA :: LocatedAn ann a -> Entry +entryFromLocatedA (L la _) = fromAnn la + +-- ===================================================================== +-- Utility stuff +-- --------------------------------------------------------------------- + +-- |This should be the final point where things are mode concrete, +-- before output. +-- NOTE: despite the name, this is the ghc-exactprint final output for +-- the PRINT phase. +printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m () +printStringAtLsDelta cl s = do + p <- getPosP + colOffset <- getLayoutOffsetP + if isGoodDeltaWithOffset cl colOffset + then do + printStringAt (undelta p cl colOffset) s + `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) + else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) + +-- --------------------------------------------------------------------- + +isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool +isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP l c) + where (l,c) = undelta (0,0) dp colOffset + +printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m () +printQueuedComment loc Comment{commentContents} dp = do + p <- getPosP + colOffset <- getLayoutOffsetP + let (dr,dc) = undelta (0,0) dp colOffset + -- do not lose comments against the left margin + when (isGoodDelta (DP dr (max 0 dc))) $ do + printCommentAt (undelta p dp colOffset) commentContents + setPriorEndASTD False loc + p' <- getPosP + debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) + +{- +-- Print version +printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +printQueuedComment Comment{commentContents} dp = do + p <- getPos + colOffset <- getLayoutOffset + let (dr,dc) = undelta (0,0) dp colOffset + -- do not lose comments against the left margin + when (isGoodDelta (DP (dr,max 0 dc))) $ + printCommentAt (undelta p dp colOffset) commentContents + +-} + +-- --------------------------------------------------------------------- + +-- withContext :: (Monad m, Monoid w) +-- => [(KeywordId, DeltaPos)] +-- -> Annotation +-- -> EP w m a -> EP w m a +-- withContext kds an x = withKds kds (withOffset an x) + +-- --------------------------------------------------------------------- +-- +-- | Given an annotation associated with a specific SrcSpan, +-- determines a new offset relative to the previous offset +-- +withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) +withOffset a = + local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) }) + +------------------------------------------------------------------------ + +setLayoutBoth :: (Monad m, Monoid w) => EP w m () -> EP w m () +setLayoutBoth k = do + oldLHS <- gets dLHS + oldAnchorOffset <- getLayoutOffsetP + debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = True + , pMarkLayout = True } ) + let reset = do + debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = False + , dLHS = oldLHS + , pMarkLayout = False + , pLHS = oldAnchorOffset} ) + k <* reset + +-- Use 'local', designed for this +setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m () -> EP w m () +setLayoutTopLevelP k = do + debugM $ "setLayoutTopLevelP entered" + oldAnchorOffset <- getLayoutOffsetP + modify (\a -> a { pMarkLayout = False + , pLHS = 1} ) + k + debugM $ "setLayoutTopLevelP:resetting" + setLayoutOffsetP oldAnchorOffset + +------------------------------------------------------------------------ + +getPosP :: (Monad m, Monoid w) => EP w m Pos +getPosP = gets epPos + +setPosP :: (Monad m, Monoid w) => Pos -> EP w m () +setPosP l = do + debugM $ "setPosP:" ++ show l + modify (\s -> s {epPos = l}) + +getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor) +getExtraDP = gets uExtraDP + +setExtraDP :: (Monad m, Monoid w) => Maybe Anchor -> EP w m () +setExtraDP md = do + debugM $ "setExtraDP:" ++ show md + modify (\s -> s {uExtraDP = md}) + +getPriorEndD :: (Monad m, Monoid w) => EP w m Pos +getPriorEndD = gets dPriorEndPosition + +getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan +getAnchorU = gets uAnchorSpan + +setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndD pe = do + -- setLayoutStartIfNeededD (snd pe) + setPriorEndNoLayoutD pe + +setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndNoLayoutD pe = do + debugM $ "setPriorEndNoLayout:pe=" ++ show pe + modify (\s -> s { dPriorEndPosition = pe }) + +setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m () +setPriorEndASTD layout pe = setPriorEndASTPD layout (rs2range pe) + +setPriorEndASTPD :: (Monad m, Monoid w) => Bool -> (Pos,Pos) -> EP w m () +setPriorEndASTPD layout pe@(fm,to) = do + debugM $ "setPriorEndASTD:pe=" ++ show pe + when layout $ setLayoutStartD (snd fm) + modify (\s -> s { dPriorEndPosition = to } ) + +setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m () +setLayoutStartD p = do + EPState{dMarkLayout} <- get + when dMarkLayout $ do + debugM $ "setLayoutStartD: setting dLHS=" ++ show p + modify (\s -> s { dMarkLayout = False + , dLHS = LayoutStartCol p}) + +setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +setAnchorU rss = do + debugM $ "setAnchorU:" ++ show (rs2range rss) + modify (\s -> s { uAnchorSpan = rss }) + +getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] +getUnallocatedComments = gets epComments + +putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m () +putUnallocatedComments cs = modify (\s -> s { epComments = cs } ) + +getLayoutOffsetP :: (Monad m, Monoid w) => EP w m LayoutStartCol +getLayoutOffsetP = gets pLHS + +setLayoutOffsetP :: (Monad m, Monoid w) => LayoutStartCol -> EP w m () +setLayoutOffsetP c = do + debugM $ "setLayoutOffsetP:" ++ show c + modify (\s -> s { pLHS = c }) + +-- getEofPos :: (Monad m, Monoid w) => EP w m RealSrcSpan +-- getEofPos = do +-- as <- gets epApiAnns +-- case apiAnnEofPos as of +-- Nothing -> return placeholderRealSpan +-- Just ss -> return ss + +-- --------------------------------------------------------------------- +------------------------------------------------------------------------- +-- |First move to the given location, then call exactP +-- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a +-- exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) +-- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a +-- exactPC ast action = +-- do +-- return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast)) +-- ma <- getAndRemoveAnnotation ast +-- let an@Ann{ annEntryDelta=edp +-- , annPriorComments=comments +-- , annFollowingComments=fcomments +-- , annsDP=kds +-- } = fromMaybe annNone ma +-- PrintOptions{epAstPrint} <- ask +-- r <- withContext kds an +-- (mapM_ (uncurry printQueuedComment) comments +-- >> advance edp +-- >> censorM (epAstPrint ast) action +-- <* mapM_ (uncurry printQueuedComment) fcomments) +-- return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast)) + +-- censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a +-- censorM f m = passM (liftM (\x -> (x,f)) m) + +-- passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a +-- passM m = RWST $ \r s -> do +-- ~((a, f),s', EPWriter w) <- runRWST m r s +-- w' <- f w +-- return (a, s', EPWriter w') + +advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () +advance dp = do + p <- getPosP + colOffset <- getLayoutOffsetP + debugM $ "advance:(p,dp,colOffset,ws)=" ++ show (p,dp,colOffset,undelta p dp colOffset) + printWhitespace (undelta p dp colOffset) + +{- +Version from Print.advance +advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () +advance cl = do + p <- getPos + colOffset <- getLayoutOffset + printWhitespace (undelta p cl colOffset) +-} + +-- --------------------------------------------------------------------- + +adjustDeltaForOffsetM :: DeltaPos -> EPP DeltaPos +adjustDeltaForOffsetM dp = do + colOffset <- gets dLHS + return (adjustDeltaForOffset 0 colOffset dp) + +-- adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos +-- adjustDeltaForOffset _ _colOffset dp@(DP (0,_)) = dp -- same line +-- adjustDeltaForOffset d (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset - d) + +-- --------------------------------------------------------------------- +-- Printing functions + +printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () +printString layout str = do + EPState{epPos = (_,c), pMarkLayout} <- get + PrintOptions{epTokenPrint, epWhitespacePrint} <- ask + when (pMarkLayout && layout) $ do + debugM $ "printString: setting pLHS to " ++ show c + modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } ) + + -- Advance position, taking care of any newlines in the string + let strDP@(DP cr _cc) = dpFromString str + p <- getPosP + colOffset <- getLayoutOffsetP + debugM $ "printString:(p,colOffset,strDP,cr)=" ++ show (p,colOffset,strDP,cr) + if cr == 0 + then setPosP (undelta p strDP colOffset) + else setPosP (undelta p strDP 1) + + -- Debug stuff + -- pp <- getPosP + -- debugM $ "printString: (p,pp,str)" ++ show (p,pp,str) + -- Debug end + + -- + if not layout && c == 0 + then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} + else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} + + +{- + +-- Print.printString +printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () +printString layout str = do + EPState{epPos = (_,c), epMarkLayout} <- get + PrintOptions{epTokenPrint, epWhitespacePrint} <- ask + when (epMarkLayout && layout) $ + modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ) + + -- Advance position, taking care of any newlines in the string + let strDP@(DP (cr,_cc)) = dpFromString str + p <- getPos + colOffset <- getLayoutOffset + if cr == 0 + then setPos (undelta p strDP colOffset) + else setPos (undelta p strDP 1) + + -- + if not layout && c == 0 + then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} + else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} + +-} + +-------------------------------------------------------- + +printStringAdvance :: String -> EPP () +printStringAdvance str = do + ss <- getAnchorU + printStringAtKw' ss str + +-------------------------------------------------------- + +newLine :: (Monad m, Monoid w) => EP w m () +newLine = do + (l,_) <- getPosP + printString False "\n" + setPosP (l+1,1) + +padUntil :: (Monad m, Monoid w) => Pos -> EP w m () +padUntil (l,c) = do + (l1,c1) <- getPosP + if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' ' + | l1 < l -> newLine >> padUntil (l,c) + | otherwise -> return () + +printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m () +printWhitespace = padUntil + +printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () +printCommentAt p str = do + debugM $ "printCommentAt: (pos,str)" ++ show (p,str) + printWhitespace p >> printString False str + +printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () +printStringAt p str = printWhitespace p >> printString True str diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs new file mode 100644 index 0000000000..8edf4ac1f0 --- /dev/null +++ b/utils/check-exact/Lookup.hs @@ -0,0 +1,137 @@ +module Lookup + ( + keywordToString + , KeywordId(..) + , Comment(..) + ) where + +-- import Language.Haskell.ExactPrint.Types +import GHC (AnnKeywordId(..)) +-- import GHC.Utils.Outputable hiding ( (<>) ) +-- import Data.Data (Data) +-- import GHC.Types.SrcLoc +-- import GHC.Driver.Session +import Types + +-- | Maps `AnnKeywordId` to the corresponding String representation. +-- There is no specific mapping for the following constructors. +-- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`, +-- `AnnInfix` +keywordToString :: KeywordId -> String +keywordToString kw = + let mkErr x = error $ "keywordToString: missing case for:" ++ show x + in + case kw of + -- Specifically handle all cases so that there are pattern match + -- warnings if new constructors are added. + AnnComment _ -> mkErr kw + AnnString _ -> mkErr kw + AnnSemiSep -> ";" + (G AnnAnyclass) -> "anyclass" + (G AnnOpen ) -> mkErr kw + (G AnnClose ) -> mkErr kw + (G AnnVal ) -> mkErr kw + (G AnnPackageName) -> mkErr kw + (G AnnHeader ) -> mkErr kw + (G AnnFunId ) -> mkErr kw + (G AnnInfix ) -> mkErr kw + (G AnnValStr ) -> mkErr kw + (G AnnName ) -> mkErr kw + (G AnnAs ) -> "as" + (G AnnAt ) -> "@" + (G AnnBang ) -> "!" + (G AnnBackquote ) -> "`" + (G AnnBy ) -> "by" + (G AnnCase ) -> "case" + (G AnnClass ) -> "class" + (G AnnCloseB ) -> "|)" + (G AnnCloseBU ) -> "⦈" + (G AnnCloseC ) -> "}" + (G AnnCloseP ) -> ")" + (G AnnClosePH ) -> "#)" + (G AnnCloseQ ) -> "|]" + (G AnnCloseQU ) -> "⟧" + (G AnnCloseS ) -> "]" + (G AnnColon ) -> ":" + (G AnnComma ) -> "," + (G AnnCommaTuple ) -> "," + (G AnnDarrow ) -> "=>" + (G AnnData ) -> "data" + (G AnnDcolon ) -> "::" + (G AnnDefault ) -> "default" + (G AnnDeriving ) -> "deriving" + (G AnnDo ) -> "do" + (G AnnDot ) -> "." + (G AnnDotdot ) -> ".." + (G AnnElse ) -> "else" + (G AnnEqual ) -> "=" + (G AnnExport ) -> "export" + (G AnnFamily ) -> "family" + (G AnnForall ) -> "forall" + (G AnnForeign ) -> "foreign" + (G AnnGroup ) -> "group" + (G AnnHiding ) -> "hiding" + (G AnnIf ) -> "if" + (G AnnImport ) -> "import" + (G AnnIn ) -> "in" + (G AnnInstance ) -> "instance" + (G AnnLam ) -> "\\" + (G AnnLarrow ) -> "<-" + (G AnnLet ) -> "let" + -- (G AnnLolly ) -> "#->" + (G AnnLollyU ) -> "⊸" + (G AnnMdo ) -> "mdo" + (G AnnMinus ) -> "-" + (G AnnModule ) -> "module" + (G AnnNewtype ) -> "newtype" + (G AnnOf ) -> "of" + (G AnnOpenB ) -> "(|" + (G AnnOpenBU ) -> "⦇" + (G AnnOpenC ) -> "{" + (G AnnOpenE ) -> "[e|" + (G AnnOpenEQ ) -> "[|" + (G AnnOpenEQU ) -> "⟦" + (G AnnOpenP ) -> "(" + (G AnnOpenPH ) -> "(#" + -- (G AnnOpenPE ) -> "$(" + -- (G AnnOpenPTE ) -> "$$(" + (G AnnOpenS ) -> "[" + (G AnnPattern ) -> "pattern" + (G AnnPercent ) -> "%" + (G AnnPercentOne) -> "%1" + (G AnnProc ) -> "proc" + (G AnnQualified ) -> "qualified" + (G AnnRarrow ) -> "->" + (G AnnRec ) -> "rec" + (G AnnRole ) -> "role" + (G AnnSafe ) -> "safe" + (G AnnSemi ) -> ";" + (G AnnSignature) -> "signature" + (G AnnStock ) -> "stock" + (G AnnStatic ) -> "static" + (G AnnThen ) -> "then" + (G AnnTilde ) -> "~" + (G AnnType ) -> "type" + (G AnnUnit ) -> "()" + (G AnnUsing ) -> "using" + (G AnnVbar ) -> "|" + (G AnnWhere ) -> "where" + (G Annlarrowtail ) -> "-<" + (G Annrarrowtail ) -> ">-" + (G AnnLarrowtail ) -> "-<<" + (G AnnRarrowtail ) -> ">>-" + (G AnnSimpleQuote ) -> "'" + (G AnnThTyQuote ) -> "''" + (G AnnDollar ) -> "$" + (G AnnDollarDollar ) -> "$$" + (G AnnDarrowU) -> "⇒" + (G AnnDcolonU) -> "∷" + (G AnnForallU) -> "∀" + (G AnnLarrowU) -> "←" + (G AnnLarrowtailU) -> "⤛" + (G AnnRarrowU) -> "→" + (G AnnRarrowtailU) -> "⤜" + (G AnnlarrowtailU) -> "⤙" + (G AnnrarrowtailU) -> "⤚" + AnnTypeApp -> "@" + (G AnnVia) -> "via" diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs new file mode 100644 index 0000000000..80c1908ce0 --- /dev/null +++ b/utils/check-exact/Main.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- import Data.List +-- import GHC.Types.SrcLoc +import GHC hiding (moduleName) +import GHC.Driver.Ppr +import GHC.Driver.Session +import GHC.Hs.Dump +-- import qualified Control.Monad.IO.Class as GHC +-- import GHC.Types.SourceText +-- import GHC.Hs.Exact hiding (ExactPrint()) +-- import GHC.Utils.Outputable hiding (space) +import System.Environment( getArgs ) +import System.Exit +import System.FilePath +import ExactPrint +-- exactPrint = undefined +-- showPprUnsafe = undefined + +-- --------------------------------------------------------------------- + +_tt :: IO () +-- _tt = testOneFile "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib" +_tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib" +-- _tt = testOneFile "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib" + + -- "../../testsuite/tests/printer/Ppr001.hs" + -- "../../testsuite/tests/printer/Ppr002.hs" + -- "../../testsuite/tests/printer/Ppr002a.hs" + -- "../../testsuite/tests/printer/Ppr003.hs" + -- "../../testsuite/tests/printer/Ppr004.hs" + -- "../../testsuite/tests/printer/Ppr005.hs" + -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" + -- "../../testsuite/tests/printer/Ppr006.hs" + -- "../../testsuite/tests/printer/Ppr007.hs" + -- "../../testsuite/tests/printer/Ppr008.hs" + -- "../../testsuite/tests/hiefile/should_compile/hie008.hs" + -- "../../testsuite/tests/printer/Ppr009.hs" + -- "../../testsuite/tests/printer/Ppr011.hs" + -- "../../testsuite/tests/printer/Ppr012.hs" + -- "../../testsuite/tests/printer/Ppr013.hs" + -- "../../testsuite/tests/printer/Ppr014.hs" + -- "../../testsuite/tests/printer/Ppr015.hs" + -- "../../testsuite/tests/printer/Ppr016.hs" + -- "../../testsuite/tests/printer/Ppr017.hs" + -- "../../testsuite/tests/printer/Ppr018.hs" + -- "../../testsuite/tests/printer/Ppr019.hs" + -- "../../testsuite/tests/printer/Ppr020.hs" + -- "../../testsuite/tests/printer/Ppr021.hs" + -- "../../testsuite/tests/printer/Ppr022.hs" + -- "../../testsuite/tests/printer/Ppr023.hs" + -- "../../testsuite/tests/printer/Ppr024.hs" + -- "../../testsuite/tests/printer/Ppr025.hs" + -- "../../testsuite/tests/printer/Ppr026.hs" + -- "../../testsuite/tests/printer/Ppr027.hs" + -- "../../testsuite/tests/printer/Ppr028.hs" + -- "../../testsuite/tests/printer/Ppr029.hs" + -- "../../testsuite/tests/printer/Ppr030.hs" + -- "../../testsuite/tests/printer/Ppr031.hs" + -- "../../testsuite/tests/printer/Ppr032.hs" + -- "../../testsuite/tests/printer/Ppr033.hs" + -- "../../testsuite/tests/printer/Ppr034.hs" + -- "../../testsuite/tests/printer/Ppr035.hs" + -- "../../testsuite/tests/printer/Ppr036.hs" + -- "../../testsuite/tests/printer/Ppr037.hs" + -- "../../testsuite/tests/printer/Ppr038.hs" + -- "../../testsuite/tests/printer/Ppr039.hs" + -- "../../testsuite/tests/printer/Ppr040.hs" + -- "../../testsuite/tests/printer/Ppr041.hs" + -- "../../testsuite/tests/printer/Ppr042.hs" + -- "../../testsuite/tests/printer/Ppr043.hs" + -- "../../testsuite/tests/printer/Ppr044.hs" + -- "../../testsuite/tests/printer/Ppr045.hs" + -- "../../testsuite/tests/printer/Ppr046.hs" + -- Not tested, the GENERATED pragma is getting removed "../../testsuite/tests/printer/Ppr047.hs" + -- "../../testsuite/tests/printer/Ppr048.hs" + -- "../../testsuite/tests/printer/Ppr049.hs" + -- "../../testsuite/tests/printer/T13050p.hs" + -- "../../testsuite/tests/printer/T13199.hs" + -- "../../testsuite/tests/printer/T13550.hs" + -- "../../testsuite/tests/printer/T13942.hs" + -- "../../testsuite/tests/printer/T14289b.hs" + -- "../../testsuite/tests/printer/T14289c.hs" + -- "../../testsuite/tests/printer/T14289.hs" + -- "../../testsuite/tests/printer/T14306.hs" + -- "../../testsuite/tests/printer/T14343b.hs" + -- "../../testsuite/tests/printer/T14343.hs" + -- "../../testsuite/tests/printer/T15761.hs" + -- "../../testsuite/tests/printer/Test17519.hs" + -- "../../testsuite/tests/printer/T18052a.hs" + -- "../../testsuite/tests/printer/T18247a.hs" + -- "../../testsuite/tests/printer/Ppr050.hs" + -- "../../testsuite/tests/printer/Ppr051.hs" + -- "../../testsuite/tests/printer/Ppr052.hs" + -- "../../testsuite/tests/typecheck/should_fail/T17566c.hs" + -- "../../testsuite/tests/hiefile/should_compile/Constructors.hs" + -- "../../testsuite/tests/printer/StarBinderAnns.hs" + -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" + -- "../../testsuite/tests/printer/Test10276.hs" + -- "../../testsuite/tests/printer/Test10278.hs" + -- "../../testsuite/tests/printer/Test12417.hs" + -- "../../testsuite/tests/parser/should_compile/T14189.hs" + -- "../../testsuite/tests/printer/Test16212.hs" + -- "../../testsuite/tests/printer/Test10312.hs" + -- "../../testsuite/tests/printer/Test10354.hs" + -- "../../testsuite/tests/printer/Test10357.hs" + -- "../../testsuite/tests/printer/Test10399.hs" + -- "../../testsuite/tests/printer/Test11018.hs" + -- "../../testsuite/tests/printer/Test11332.hs" + -- "../../testsuite/tests/printer/Test16230.hs" + -- "../../testsuite/tests/printer/Test16236.hs" + -- "../../testsuite/tests/printer/AnnotationLet.hs" + -- "../../testsuite/tests/printer/AnnotationTuple.hs" + -- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" + -- "../../testsuite/tests/hiefile/should_compile/Scopes.hs" + -- "../../testsuite/tests/printer/Ppr053.hs" + -- "../../testsuite/tests/printer/Ppr054.hs" + -- "../../testsuite/tests/printer/Ppr055.hs" + -- "../../testsuite/tests/hiefile/should_run/PatTypes.hs" + -- "./cases/LocalDecls2.expected.hs" + -- "./cases/WhereIn3a.hs" + -- "./cases/AddLocalDecl1.hs" + -- "./cases/LayoutIn1.hs" + -- "./cases/EmptyWheres.hs" + -- "../../testsuite/tests/printer/PprRecordDotSyntax1.hs" + -- "../../testsuite/tests/printer/PprRecordDotSyntax2.hs" + -- "../../testsuite/tests/printer/PprRecordDotSyntax3.hs" + -- "../../testsuite/tests/printer/PprRecordDotSyntax4.hs" + "../../testsuite/tests/printer/PprRecordDotSyntaxA.hs" + -- "./cases/Windows.hs" + +-- exact = ppr + +-- --------------------------------------------------------------------- + +usage :: String +usage = unlines + [ "usage: check-exact (libdir) (file)" + , "" + , "where libdir is the GHC library directory (e.g. the output of" + , "ghc --print-libdir) and file is the file to parse." + ] + +main :: IO() +main = do + args <- getArgs + case args of + [libdir,fileName] -> testOneFile libdir fileName + _ -> putStrLn usage + +testOneFile :: FilePath -> String -> IO () +testOneFile libdir fileName = do + p <- parseOneFile libdir fileName + -- putStrLn $ "\n\ngot p" + let + origAst = showSDocUnsafe + $ showAstData BlankSrcSpanFile NoBlankApiAnnotations + (pm_parsed_source p) + anns' = pm_annotations p + -- pped = pragmas ++ "\n" ++ (exactPrint $ pm_parsed_source p) + pped = exactPrint (pm_parsed_source p) anns' + -- pragmas = getPragmas anns' + + newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName + astFile = fileName <.> "ast" + newAstFile = fileName <.> "ast.new" + + -- putStrLn $ "\n\nabout to writeFile" + writeFile astFile origAst + -- putStrLn $ "\n\nabout to pp" + writeFile newFile pped + + -- putStrLn $ "anns':" ++ showPprUnsafe (apiAnnRogueComments anns') + + p' <- parseOneFile libdir newFile + + let newAstStr :: String + newAstStr = showSDocUnsafe + $ showAstData BlankSrcSpanFile NoBlankApiAnnotations + (pm_parsed_source p') + writeFile newAstFile newAstStr + + -- putStrLn $ "\n\nanns':" ++ showPprUnsafe (apiAnnRogueComments anns') + + if origAst == newAstStr + then do + -- putStrLn "ASTs matched" + exitSuccess + else do + putStrLn "exactPrint AST Match Failed" + putStrLn "\n===================================\nOrig\n\n" + putStrLn origAst + putStrLn "\n===================================\nNew\n\n" + putStrLn newAstStr + putStrLn "\n===================================\n\n" + exitFailure + + +parseOneFile :: FilePath -> FilePath -> IO ParsedModule +parseOneFile libdir fileName = do + let modByFile m = + case ml_hs_file $ ms_location m of + Nothing -> False + Just fn -> fn == fileName + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream + _ <- setSessionDynFlags dflags2 + addTarget Target { targetId = TargetFile fileName Nothing + , targetAllowObjCode = True + , targetContents = Nothing } + _ <- load LoadAllTargets + graph <- getModuleGraph + let + modSum = case filter modByFile (mgModSummaries graph) of + [x] -> x + xs -> error $ "Can't find module, got:" + ++ show (map (ml_hs_file . ms_location) xs) + -- toks <- getRichTokenStream (ms_mod modSum) + -- toks <- getTokenStream (ms_mod modSum) + -- GHC.liftIO $ putStrLn $ "toks=" ++ showPprUnsafe toks + parseModule modSum + +-- getPragmas :: ApiAnns -> String +-- getPragmas anns' = pragmaStr +-- where +-- tokComment (L _ (AnnBlockComment s)) = s +-- tokComment (L _ (AnnLineComment s)) = s +-- tokComment _ = "" + +-- comments' = map tokComment $ sortRealLocated $ apiAnnRogueComments anns' +-- pragmas = filter (\c -> isPrefixOf "{-#" c ) comments' +-- pragmaStr = intercalate "\n" pragmas + +-- pp :: (Outputable a) => a -> String +-- pp a = showPpr unsafeGlobalDynFlags a + +-- --------------------------------------------------------------------- diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs new file mode 100644 index 0000000000..403ee3e55d --- /dev/null +++ b/utils/check-exact/Parsers.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- This module rexposes wrapped parsers from the GHC API. Along with +-- returning the parse result, the corresponding annotations are also +-- returned such that it is then easy to modify the annotations and print +-- the result. +-- +---------------------------------------------------------------------------- +module Parsers ( + -- * Utility + Parser + , ParseResult + , withDynFlags + , CppOptions(..) + , defaultCppOptions + + -- * Module Parsers + , parseModule + , parseModuleFromString + , parseModuleWithOptions + , parseModuleWithCpp + + -- * Basic Parsers + , parseExpr + , parseImport + , parseType + , parseDecl + , parsePattern + , parseStmt + + , parseWith + + -- * Internal + + , ghcWrapper + + , initDynFlags + , initDynFlagsPure + , parseModuleFromStringInternal + , parseModuleApiAnnsWithCpp + , parseModuleApiAnnsWithCppInternal + , postParseTransform + ) where + +-- import Language.Haskell.GHC.ExactPrint.Annotate +-- import Language.Haskell.GHC.ExactPrint.Delta +import Preprocess +import Types + +import Control.Monad.RWS +-- import Data.Data (Data) + + +-- import GHC.Paths (libdir) + +import qualified GHC hiding (parseModule) +import qualified Control.Monad.IO.Class as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Parser as GHC +import qualified GHC.Parser.Header as GHC +import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Parser.PostProcess as GHC +import qualified GHC.Parser.Errors.Ppr as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Error as GHC + +import qualified GHC.LanguageExtensions as LangExt + +-- import qualified Data.Map as Map + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- + +-- | Wrapper function which returns Annotations along with the parsed +-- element. +parseWith :: GHC.DynFlags + -> FilePath + -> GHC.P w + -> String + -> ParseResult w +parseWith dflags fileName parser s = + case runParser parser dflags fileName s of + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk (mkApiAnns -> apianns) pmod -> Right (apianns, pmod) + + +parseWithECP :: (GHC.DisambECP w) + => GHC.DynFlags + -> FilePath + -> GHC.P GHC.ECP + -> String + -> ParseResult (GHC.LocatedA w) +parseWithECP dflags fileName parser s = + -- case runParser ff dflags fileName s of + -- case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of + case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk (mkApiAnns -> apianns) pmod -> Right (apianns, pmod) + +-- --------------------------------------------------------------------- + +runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a +runParser parser flags filename str = GHC.unP parser parseState + where + location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 + buffer = GHC.stringToStringBuffer str + parseState = GHC.initParserState (GHC.initParserOpts flags) buffer location + +-- --------------------------------------------------------------------- + +-- | Provides a safe way to consume a properly initialised set of +-- 'DynFlags'. +-- +-- @ +-- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr) +-- @ +withDynFlags :: FilePath -> (GHC.DynFlags -> a) -> IO a +withDynFlags libdir action = ghcWrapper libdir $ do + dflags <- GHC.getSessionDynFlags + void $ GHC.setSessionDynFlags dflags + return (action dflags) + +-- --------------------------------------------------------------------- + +parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule) +parseFile = runParser GHC.parseModule + +-- --------------------------------------------------------------------- + +type ParseResult a = Either GHC.ErrorMessages (GHC.ApiAnns, a) + +type Parser a = GHC.DynFlags -> FilePath -> String + -> ParseResult a + +parseExpr :: Parser (GHC.LHsExpr GHC.GhcPs) +parseExpr df fp = parseWithECP df fp GHC.parseExpression + +parseImport :: Parser (GHC.LImportDecl GHC.GhcPs) +parseImport df fp = parseWith df fp GHC.parseImport + +parseType :: Parser (GHC.LHsType GHC.GhcPs) +parseType df fp = parseWith df fp GHC.parseType + +-- safe, see D1007 +parseDecl :: Parser (GHC.LHsDecl GHC.GhcPs) +parseDecl df fp = parseWith df fp GHC.parseDeclaration + +parseStmt :: Parser (GHC.ExprLStmt GHC.GhcPs) +parseStmt df fp = parseWith df fp GHC.parseStatement + +parsePattern :: Parser (GHC.LPat GHC.GhcPs) +parsePattern df fp = parseWith df fp GHC.parsePattern + +-- --------------------------------------------------------------------- +-- + +-- | This entry point will also work out which language extensions are +-- required and perform CPP processing if necessary. +-- +-- @ +-- parseModule = parseModuleWithCpp defaultCppOptions +-- @ +-- +-- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs') +parseModule :: FilePath -> FilePath -> IO (ParseResult GHC.ParsedSource) +parseModule libdir file = parseModuleWithCpp libdir defaultCppOptions file + + +-- | This entry point will work out which language extensions are +-- required but will _not_ perform CPP processing. +-- In contrast to `parseModoule` the input source is read from the provided +-- string; the `FilePath` parameter solely exists to provide a name +-- in source location annotations. +parseModuleFromString + :: FilePath -- GHC libdir + -> FilePath + -> String + -> IO (ParseResult GHC.ParsedSource) +parseModuleFromString libdir fp s = ghcWrapper libdir $ do + dflags <- initDynFlagsPure fp s + return $ parseModuleFromStringInternal dflags fp s + +-- | Internal part of 'parseModuleFromString'. +parseModuleFromStringInternal :: Parser GHC.ParsedSource +parseModuleFromStringInternal dflags fileName str = + let (str1, lp) = stripLinePragmas str + res = case runParser GHC.parseModule dflags fileName str1 of + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk x pmod -> Right (mkApiAnns x, lp, dflags, pmod) + in postParseTransform res + +parseModuleWithOptions :: FilePath -- ^ GHC libdir + -> FilePath + -> IO (ParseResult GHC.ParsedSource) +parseModuleWithOptions libdir fp = + parseModuleWithCpp libdir defaultCppOptions fp + + +-- | Parse a module with specific instructions for the C pre-processor. +parseModuleWithCpp + :: FilePath -- ^ GHC libdir + -> CppOptions + -> FilePath -- ^ File to be parsed + -> IO (ParseResult GHC.ParsedSource) +parseModuleWithCpp libdir cpp fp = do + res <- parseModuleApiAnnsWithCpp libdir cpp fp + return $ postParseTransform res + +-- --------------------------------------------------------------------- + +-- | Low level function which is used in the internal tests. +-- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of +-- this function. +parseModuleApiAnnsWithCpp + :: FilePath -- ^ GHC libdir + -> CppOptions + -> FilePath -- ^ File to be parsed + -> IO + ( Either + GHC.ErrorMessages + (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ) +parseModuleApiAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do + dflags <- initDynFlags file + parseModuleApiAnnsWithCppInternal cppOptions dflags file + +-- | Internal function. Default runner of GHC.Ghc action in IO. +ghcWrapper :: FilePath -> GHC.Ghc a -> IO a +ghcWrapper libdir a = + GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut + $ GHC.runGhc (Just libdir) a + +-- | Internal function. Exposed if you want to muck with DynFlags +-- before parsing. +parseModuleApiAnnsWithCppInternal + :: GHC.GhcMonad m + => CppOptions + -> GHC.DynFlags + -> FilePath + -> m + ( Either + GHC.ErrorMessages + (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + ) +parseModuleApiAnnsWithCppInternal cppOptions dflags file = do + let useCpp = GHC.xopt LangExt.Cpp dflags + (fileContents, injectedComments, dflags') <- + if useCpp + then do + (contents,dflags1) <- getPreprocessedSrcDirect cppOptions file + cppComments <- getCppTokensAsComments cppOptions file + return (contents,cppComments,dflags1) + else do + txt <- GHC.liftIO $ readFileGhc file + let (contents1,lp) = stripLinePragmas txt + return (contents1,lp,dflags) + return $ + case parseFile dflags' file fileContents of + GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) + GHC.POk (mkApiAnns -> apianns) pmod -> + Right $ (apianns, injectedComments, dflags', pmod) + +-- | Internal function. Exposed if you want to muck with DynFlags +-- before parsing. Or after parsing. +postParseTransform + :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) + -> Either a (GHC.ApiAnns, GHC.ParsedSource) +postParseTransform parseRes = fmap mkAnns parseRes + where + mkAnns (apianns, _cs, _, m) = (apianns, m) + -- (relativiseApiAnnsWithOptions opts cs m apianns, m) + +-- | Internal function. Initializes DynFlags value for parsing. +-- +-- Passes "-hide-all-packages" to the GHC API to prevent parsing of +-- package environment files. However this only works if there is no +-- invocation of `setSessionDynFlags` before calling `initDynFlags`. +-- See ghc tickets #15513, #15541. +initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags +initDynFlags file = do + dflags0 <- GHC.getSessionDynFlags + src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file + (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts + -- Turn this on last to avoid T10942 + let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream + -- Prevent parsing of .ghc.environment.* "package environment files" + (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + dflags2 + [GHC.noLoc "-hide-all-packages"] + _ <- GHC.setSessionDynFlags dflags3 + return dflags3 + +-- | Requires GhcMonad constraint because there is +-- no pure variant of `parseDynamicFilePragma`. Yet, in constrast to +-- `initDynFlags`, it does not (try to) read the file at filepath, but +-- solely depends on the module source in the input string. +-- +-- Passes "-hide-all-packages" to the GHC API to prevent parsing of +-- package environment files. However this only works if there is no +-- invocation of `setSessionDynFlags` before calling `initDynFlagsPure`. +-- See ghc tickets #15513, #15541. +initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags +initDynFlagsPure fp s = do + -- I was told we could get away with using the unsafeGlobalDynFlags. + -- as long as `parseDynamicFilePragma` is impure there seems to be + -- no reason to use it. + dflags0 <- GHC.getSessionDynFlags + let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer $ s) fp + (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo + -- Turn this on last to avoid T10942 + let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream + -- Prevent parsing of .ghc.environment.* "package environment files" + (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + dflags2 + [GHC.noLoc "-hide-all-packages"] + _ <- GHC.setSessionDynFlags dflags3 + return dflags3 + +-- --------------------------------------------------------------------- + +mkApiAnns :: GHC.PState -> GHC.ApiAnns +mkApiAnns pstate + = GHC.ApiAnns { + GHC.apiAnnRogueComments = GHC.comment_q pstate + } diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs new file mode 100644 index 0000000000..aa474df2b1 --- /dev/null +++ b/utils/check-exact/Preprocess.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides support for CPP, interpreter directives and line +-- pragmas. +module Preprocess + ( + stripLinePragmas + , getCppTokensAsComments + , getPreprocessedSrcDirect + , readFileGhc + + , CppOptions(..) + , defaultCppOptions + ) where + +import qualified GHC as GHC hiding (parseModule) + +import qualified Control.Monad.IO.Class as GHC +import qualified GHC.Data.Bag as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Env as GHC +import qualified GHC.Driver.Phases as GHC +import qualified GHC.Driver.Pipeline as GHC +import qualified GHC.Fingerprint.Type as GHC +import qualified GHC.Parser.Errors.Ppr as GHC +import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Settings as GHC +import qualified GHC.Types.SourceError as GHC +import qualified GHC.Types.SourceFile as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Error as GHC +import qualified GHC.Utils.Fingerprint as GHC +import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) +import GHC.Data.FastString (mkFastString) + +import Data.List hiding (find) +import Data.Maybe +import Types +import Utils +import qualified Data.Set as Set + + +-- import Debug.Trace +-- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +-- --------------------------------------------------------------------- + +data CppOptions = CppOptions + { cppDefine :: [String] -- ^ CPP #define macros + , cppInclude :: [FilePath] -- ^ CPP Includes directory + , cppFile :: [FilePath] -- ^ CPP pre-include file + } + +defaultCppOptions :: CppOptions +defaultCppOptions = CppOptions [] [] [] + +-- --------------------------------------------------------------------- +-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments. +stripLinePragmas :: String -> (String, [Comment]) +stripLinePragmas = unlines' . unzip . findLines . lines + where + unlines' (a, b) = (unlines a, catMaybes b) + +findLines :: [String] -> [(String, Maybe Comment)] +findLines = zipWith checkLine [1..] + +checkLine :: Int -> String -> (String, Maybe Comment) +checkLine line s + | "{-# LINE" `isPrefixOf` s = + let (pragma, res) = getPragma s + size = length pragma + mSrcLoc = mkSrcLoc (mkFastString "LINE") + ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1)) + in (res, Just $ mkComment pragma (GHC.spanAsAnchor ss)) + -- Deal with shebang/cpp directives too + -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s) + | "#!" `isPrefixOf` s = + let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG") + ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s)) + in + ("",Just $ mkComment s (GHC.spanAsAnchor ss)) + | otherwise = (s, Nothing) + +getPragma :: String -> (String, String) +getPragma [] = error "Input must not be empty" +getPragma s@(x:xs) + | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s) + | otherwise = + let (prag, remline) = getPragma xs + in (x:prag, ' ':remline) + +-- --------------------------------------------------------------------- + +-- | Replacement for original 'getRichTokenStream' which will return +-- the tokens for a file processed by CPP. +-- See bug <http://ghc.haskell.org/trac/ghc/ticket/8265> +getCppTokensAsComments :: GHC.GhcMonad m + => CppOptions -- ^ Preprocessor Options + -> FilePath -- ^ Path to source file + -> m [Comment] +getCppTokensAsComments cppOptions sourceFile = do + source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile + let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1 + (_txt,strSrcBuf,flags2') <- getPreprocessedSrcDirectPrim cppOptions sourceFile + let flags2 = GHC.initParserOpts flags2' + -- hash-ifdef tokens + directiveToks <- GHC.liftIO $ getPreprocessorAsComments sourceFile + -- Tokens without hash-ifdef + nonDirectiveToks <- tokeniseOriginalSrc startLoc flags2 source + case GHC.lexTokenStream flags2 strSrcBuf startLoc of + GHC.POk _ ts -> + do + let toks = GHC.addSourceToTokens startLoc source ts + cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks + return $ filter goodComment + $ map (tokComment . GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks + GHC.PFailed pst -> parseError pst + +goodComment :: Comment -> Bool +goodComment (Comment "" _ _) = False +goodComment _ = True + + +toRealLocated :: GHC.Located a -> GHC.RealLocated a +toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s x +toRealLocated (GHC.L _ x) = GHC.L badRealSrcSpan x + +-- --------------------------------------------------------------------- + +-- | Combine the three sets of tokens to produce a single set that +-- represents the code compiled, and will regenerate the original +-- source file. +-- [@directiveToks@] are the tokens corresponding to preprocessor +-- directives, converted to comments +-- [@origSrcToks@] are the tokenised source of the original code, with +-- the preprocessor directives stripped out so that +-- the lexer does not complain +-- [@postCppToks@] are the tokens that the compiler saw originally +-- NOTE: this scheme will only work for cpp in -nomacro mode +getCppTokens :: + [(GHC.Located GHC.Token, String)] + -> [(GHC.Located GHC.Token, String)] + -> [(GHC.Located GHC.Token, String)] + -> [(GHC.Located GHC.Token, String)] +getCppTokens directiveToks origSrcToks postCppToks = toks + where + locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare (rs l1) (rs l2) + m1Toks = mergeBy locFn postCppToks directiveToks + + -- We must now find the set of tokens that are in origSrcToks, but + -- not in m1Toks + + -- GHC.Token does not have Ord, can't use a set directly + origSpans = map (\(GHC.L l _,_) -> rs l) origSrcToks + m1Spans = map (\(GHC.L l _,_) -> rs l) m1Toks + missingSpans = Set.fromList origSpans Set.\\ Set.fromList m1Spans + + missingToks = filter (\(GHC.L l _,_) -> Set.member (rs l) missingSpans) origSrcToks + + missingAsComments = map mkCommentTok missingToks + where + mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String) + mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s placeholderBufSpan),s) + + toks = mergeBy locFn directiveToks missingAsComments + +-- --------------------------------------------------------------------- + +tokeniseOriginalSrc :: + GHC.GhcMonad m + => GHC.RealSrcLoc -> GHC.ParserOpts -> GHC.StringBuffer + -> m [(GHC.Located GHC.Token, String)] +tokeniseOriginalSrc startLoc flags buf = do + let src = stripPreprocessorDirectives buf + case GHC.lexTokenStream flags src startLoc of + GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts + GHC.PFailed pst -> parseError pst + +-- --------------------------------------------------------------------- + +-- | Strip out the CPP directives so that the balance of the source +-- can tokenised. +stripPreprocessorDirectives :: GHC.StringBuffer -> GHC.StringBuffer +stripPreprocessorDirectives buf = buf' + where + srcByLine = lines $ sbufToString buf + noDirectivesLines = map (\line -> if line /= [] && head line == '#' then "" else line) srcByLine + buf' = GHC.stringToStringBuffer $ unlines noDirectivesLines + +-- --------------------------------------------------------------------- + +sbufToString :: GHC.StringBuffer -> String +sbufToString sb@(GHC.StringBuffer _buf len _cur) = GHC.lexemeToString sb len + +-- --------------------------------------------------------------------- +getPreprocessedSrcDirect :: (GHC.GhcMonad m) + => CppOptions + -> FilePath + -> m (String, GHC.DynFlags) +getPreprocessedSrcDirect cppOptions src = + (\(s,_,d) -> (s,d)) <$> getPreprocessedSrcDirectPrim cppOptions src + +getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m) + => CppOptions + -> FilePath + -> m (String, GHC.StringBuffer, GHC.DynFlags) +getPreprocessedSrcDirectPrim cppOptions src_fn = do + hsc_env <- GHC.getSession + let dfs = GHC.hsc_dflags hsc_env + new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } + -- (dflags', hspp_fn) <- + r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) + case r of + Left err -> error $ showErrorMessages err + Right (dflags', hspp_fn) -> do + buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn + txt <- GHC.liftIO $ readFileGhc hspp_fn + return (txt, buf, dflags') + +showErrorMessages :: GHC.ErrorMessages -> String +showErrorMessages msgs = intercalate "\n" $ map show $ GHC.bagToList msgs + +injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags +injectCppOptions CppOptions{..} dflags = + foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile) + where + mkDefine = ("-D" ++) + mkIncludeDir = ("-I" ++) + mkInclude = ("-include" ++) + + +addOptP :: String -> GHC.DynFlags -> GHC.DynFlags +addOptP f = alterToolSettings $ \s -> s + { GHC.toolSettings_opt_P = f : GHC.toolSettings_opt_P s + , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s) + } +alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags +alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) } + +fingerprintStrings :: [String] -> GHC.Fingerprint +fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss + +-- --------------------------------------------------------------------- + +-- | Get the preprocessor directives as comment tokens from the +-- source. +getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)] +getPreprocessorAsComments srcFile = do + fcontents <- readFileGhc srcFile + let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#') + $ zip [1..] (lines fcontents) + + let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line placeholderBufSpan),line) + where + start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1 + end = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line) + l = GHC.mkSrcSpan start end + + let toks = map mkTok directives + return toks + +placeholderBufSpan :: GHC.PsSpan +placeholderBufSpan = pspan + where + bl = GHC.BufPos 0 + pspan = GHC.PsSpan GHC.placeholderRealSpan (GHC.BufSpan bl bl) + +-- --------------------------------------------------------------------- + +parseError :: (GHC.MonadIO m) => GHC.PState -> m b +parseError pst = do + let + -- (warns,errs) = GHC.getMessages pst dflags + -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) + GHC.throwErrors (fmap GHC.pprError (GHC.getErrorMessages pst)) + +-- --------------------------------------------------------------------- + +readFileGhc :: FilePath -> IO String +readFileGhc file = do + buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file + return (GHC.lexemeToString buf len) + +-- --------------------------------------------------------------------- + +-- Copied over from MissingH, the dependency cause travis to fail + +{- | Merge two sorted lists using into a single, sorted whole, +allowing the programmer to specify the comparison function. + +QuickCheck test property: + +prop_mergeBy xs ys = + mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys) + where types = xs :: [ (Int, Int) ] + cmp (x1,_) (x2,_) = compare x1 x2 +-} +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy _cmp [] ys = ys +mergeBy _cmp xs [] = xs +mergeBy cmp (allx@(x:xs)) (ally@(y:ys)) + -- Ordering derives Eq, Ord, so the comparison below is valid. + -- Explanation left as an exercise for the reader. + -- Someone please put this code out of its misery. + | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally + | otherwise = y : mergeBy cmp allx ys + diff --git a/utils/check-exact/README b/utils/check-exact/README new file mode 100644 index 0000000000..b27f0fbd55 --- /dev/null +++ b/utils/check-exact/README @@ -0,0 +1,24 @@ + +This programme is intended to be used by any GHC developers working on +the AST and/or pretty printer by providing a way to check that using +exact print on the ParsedSource reproduces the original source. +Except for stripping trailing whitespace on lines, and discarding +tabs. + +This utility is also intended to be used in tests, so that when new features are +added the ability to round-trip the AST via exact is tested. + +Usage + +In a test Makefile + + $(CHECK_EXACT) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" FileToParse.hs + +AZ: update the rest here +See examples in (REPO_HOME)/testsuite/tests/printer/Makefile + +The utility generates the following files for ToBeTested.hs + + - ToBeTested.ppr.hs : the ppr result + - ToBeTested.hs.ast : the AST of the original source + - ToBeTested.hs.ast.new : the AST of the re-parsed ppr source diff --git a/utils/check-exact/Test.hs b/utils/check-exact/Test.hs new file mode 100644 index 0000000000..57c09cc737 --- /dev/null +++ b/utils/check-exact/Test.hs @@ -0,0 +1,840 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +import Data.List +import Data.Data +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC hiding (moduleName) +import GHC.Driver.Ppr +import GHC.Driver.Session +import GHC.Hs.Dump +import GHC.Data.Bag +import System.Environment( getArgs ) +import System.Exit +import System.FilePath + +import Types +import Utils +import ExactPrint +import Transform +import Parsers + +import GHC.Parser.Lexer +import GHC.Data.FastString +import GHC.Types.SrcLoc + +-- --------------------------------------------------------------------- + +_tt :: IO () +-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib" +_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib" +-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib" + "cases/RenameCase1.hs" changeRenameCase1 + -- "cases/LayoutLet2.hs" changeLayoutLet2 + -- "cases/LayoutLet3.hs" changeLayoutLet3 + -- "cases/LayoutLet4.hs" changeLayoutLet3 + -- "cases/Rename1.hs" changeRename1 + -- "cases/Rename2.hs" changeRename2 + -- "cases/LayoutIn1.hs" changeLayoutIn1 + -- "cases/LayoutIn3.hs" changeLayoutIn3 + -- "cases/LayoutIn3a.hs" changeLayoutIn3 + -- "cases/LayoutIn3b.hs" changeLayoutIn3 + -- "cases/LayoutIn4.hs" changeLayoutIn4 + -- "cases/LocToName.hs" changeLocToName + -- "cases/LetIn1.hs" changeLetIn1 + -- "cases/WhereIn4.hs" changeWhereIn4 + -- "cases/AddDecl1.hs" changeAddDecl1 + -- "cases/AddDecl2.hs" changeAddDecl2 + -- "cases/AddDecl3.hs" changeAddDecl3 + -- "cases/LocalDecls.hs" changeLocalDecls + -- "cases/LocalDecls2.hs" changeLocalDecls2 + -- "cases/WhereIn3a.hs" changeWhereIn3a + -- "cases/WhereIn3b.hs" changeWhereIn3b + -- "cases/AddLocalDecl1.hs" addLocaLDecl1 + -- "cases/AddLocalDecl2.hs" addLocaLDecl2 + -- "cases/AddLocalDecl3.hs" addLocaLDecl3 + -- "cases/AddLocalDecl4.hs" addLocaLDecl4 + -- "cases/AddLocalDecl5.hs" addLocaLDecl5 + -- "cases/AddLocalDecl6.hs" addLocaLDecl6 + -- "cases/RmDecl1.hs" rmDecl1 + -- "cases/RmDecl2.hs" rmDecl2 + -- "cases/RmDecl3.hs" rmDecl3 + -- "cases/RmDecl4.hs" rmDecl4 + -- "cases/RmDecl5.hs" rmDecl5 + -- "cases/RmDecl6.hs" rmDecl6 + -- "cases/RmDecl7.hs" rmDecl7 + -- "cases/RmTypeSig1.hs" rmTypeSig1 + -- "cases/RmTypeSig2.hs" rmTypeSig2 + -- "cases/AddHiding1.hs" addHiding1 + -- "cases/AddHiding2.hs" addHiding2 + +-- cloneT does not need a test, function can be retired + + +-- exact = ppr + +changers :: [(String, Changer)] +changers = + [("noChange", noChange) + ,("changeRenameCase1", changeRenameCase1) + ,("changeLayoutLet2", changeLayoutLet2) + ,("changeLayoutLet3", changeLayoutLet3) + ,("changeLayoutIn1", changeLayoutIn1) + ,("changeLayoutIn3", changeLayoutIn3) + ,("changeLayoutIn4", changeLayoutIn4) + ,("changeLocToName", changeLocToName) + ,("changeRename1", changeRename1) + ,("changeRename2", changeRename2) + ,("changeWhereIn4", changeWhereIn4) + ,("changeLetIn1", changeLetIn1) + ,("changeAddDecl1", changeAddDecl1) + ,("changeAddDecl2", changeAddDecl2) + ,("changeAddDecl3", changeAddDecl3) + ,("changeLocalDecls", changeLocalDecls) + ,("changeLocalDecls2", changeLocalDecls2) + ,("changeWhereIn3a", changeWhereIn3a) + ,("changeWhereIn3b", changeWhereIn3b) + ,("addLocaLDecl1", addLocaLDecl1) + ,("addLocaLDecl2", addLocaLDecl2) + ,("addLocaLDecl3", addLocaLDecl3) + ,("addLocaLDecl4", addLocaLDecl4) + ,("addLocaLDecl5", addLocaLDecl5) + ,("addLocaLDecl6", addLocaLDecl6) + ,("rmDecl1", rmDecl1) + ,("rmDecl2", rmDecl2) + ,("rmDecl3", rmDecl3) + ,("rmDecl4", rmDecl4) + ,("rmDecl5", rmDecl5) + ,("rmDecl6", rmDecl6) + ,("rmDecl7", rmDecl7) + ,("rmTypeSig1", rmTypeSig1) + ,("rmTypeSig2", rmTypeSig2) + ,("addHiding1", addHiding1) + ,("addHiding2", addHiding2) + ,("addHiding2", addHiding2) + ] + +-- --------------------------------------------------------------------- + +usage :: String +usage = unlines + [ "usage: check-ppr (libdir) (file)" + , "" + , "where libdir is the GHC library directory (e.g. the output of" + , "ghc --print-libdir) and file is the file to parse." + ] + +main :: IO() +main = do + args <- getArgs + case args of + [libdir,fileName] -> testOneFile changers libdir fileName noChange + _ -> putStrLn usage + +deriving instance Data Token +deriving instance Data PsSpan +deriving instance Data BufSpan +deriving instance Data BufPos + +testOneFile :: [(String, Changer)] -> FilePath -> String -> Changer -> IO () +testOneFile _ libdir fileName changer = do + (p,_toks) <- parseOneFile libdir fileName + -- putStrLn $ "\n\ngot p" ++ showAst (take 4 $ reverse toks) + let + origAst = ppAst (pm_parsed_source p) + anns' = pm_annotations p + -- pped = pragmas ++ "\n" ++ (exactPrint $ pm_parsed_source p) + pped = exactPrint (pm_parsed_source p) anns' + -- pragmas = getPragmas anns' + + newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName + newFileChanged = dropExtension fileName <.> "changed" <.> takeExtension fileName + newFileExpected = dropExtension fileName <.> "expected" <.> takeExtension fileName + astFile = fileName <.> "ast" + newAstFile = fileName <.> "ast.new" + changedAstFile = fileName <.> "ast.changed" + + -- pped' <- exactprintWithChange changeRenameCase1 (pm_parsed_source p) anns' + (pped', ast') <- exactprintWithChange libdir changer (pm_parsed_source p) anns' + -- putStrLn $ "\n\nabout to writeFile" + writeFile changedAstFile (ppAst ast') + writeFile astFile origAst + -- putStrLn $ "\n\nabout to pp" + writeFile newFile pped + writeFile newFileChanged pped' + + -- putStrLn $ "anns':" ++ showPprUnsafe (apiAnnRogueComments anns') + + (p',_) <- parseOneFile libdir newFile + + let newAstStr :: String + newAstStr = ppAst (pm_parsed_source p') + writeFile newAstFile newAstStr + expectedSource <- readFile newFileExpected + changedSource <- readFile newFileChanged + + -- putStrLn $ "\n\nanns':" ++ showPprUnsafe (apiAnnRogueComments anns') + + let + origAstOk = origAst == newAstStr + changedSourceOk = expectedSource == changedSource + if origAstOk && changedSourceOk + then do + -- putStrLn "ASTs matched" + exitSuccess + else if not origAstOk + then do + putStrLn "AST Match Failed" + -- putStrLn "\n===================================\nOrig\n\n" + -- putStrLn origAst + putStrLn "\n===================================\nNew\n\n" + putStrLn newAstStr + exitFailure + else do + putStrLn "Changed AST Source Mismatch" + putStrLn "\n===================================\nExpected\n\n" + putStrLn expectedSource + putStrLn "\n===================================\nChanged\n\n" + putStrLn changedSource + putStrLn "\n===================================\n" + putStrLn $ show changedSourceOk + exitFailure + +ppAst :: Data a => a -> String +ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankApiAnnotations ast + +parseOneFile :: FilePath -> FilePath -> IO (ParsedModule, [Located Token]) +parseOneFile libdir fileName = do + let modByFile m = + case ml_hs_file $ ms_location m of + Nothing -> False + Just fn -> fn == fileName + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream + _ <- setSessionDynFlags dflags2 + addTarget Target { targetId = TargetFile fileName Nothing + , targetAllowObjCode = True + , targetContents = Nothing } + _ <- load LoadAllTargets + graph <- getModuleGraph + let + modSum = case filter modByFile (mgModSummaries graph) of + [x] -> x + xs -> error $ "Can't find module, got:" + ++ show (map (ml_hs_file . ms_location) xs) + pm <- GHC.parseModule modSum + toks <- getTokenStream (ms_mod modSum) + return (pm, toks) + + -- getTokenStream :: GhcMonad m => Module -> m [Located Token] + +-- getPragmas :: ApiAnns -> String +-- getPragmas anns' = pragmaStr +-- where +-- tokComment (L _ (AnnBlockComment s)) = s +-- tokComment (L _ (AnnLineComment s)) = s +-- tokComment _ = "" + +-- comments' = map tokComment $ sortRealLocated $ apiAnnRogueComments anns' +-- pragmas = filter (\c -> isPrefixOf "{-#" c ) comments' +-- pragmaStr = intercalate "\n" pragmas + +-- pp :: (Outputable a) => a -> String +-- pp a = showPpr unsafeGlobalDynFlags a + +-- --------------------------------------------------------------------- + +exactprintWithChange :: FilePath -> Changer -> ParsedSource -> ApiAnns -> IO (String, ParsedSource) +exactprintWithChange libdir f p anns = do + debugM $ "exactprintWithChange:anns=" ++ showGhc (apiAnnRogueComments anns) + (anns',p') <- f libdir anns p + return (exactPrint p' anns', p') + + +-- First param is libdir +type Changer = FilePath -> (ApiAnns -> ParsedSource -> IO (ApiAnns,ParsedSource)) + +noChange :: Changer +noChange _libdir ans parsed = return (ans,parsed) + +changeRenameCase1 :: Changer +changeRenameCase1 _libdir ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed) + +changeLayoutLet2 :: Changer +changeLayoutLet2 _libdir ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) + +changeLayoutLet3 :: Changer +changeLayoutLet3 _libdir ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed) + +changeLayoutIn1 :: Changer +changeLayoutIn1 _libdir ans parsed = return (ans,rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed) + +changeLayoutIn3 :: Changer +changeLayoutIn3 _libdir ans parsed = return (ans,rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed) + +changeLayoutIn4 :: Changer +changeLayoutIn4 _libdir ans parsed = return (ans,rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed) + +changeLocToName :: Changer +changeLocToName _libdir ans parsed = return (ans,rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed) + + +changeRename1 :: Changer +changeRename1 _libdir ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed) + +changeRename2 :: Changer +changeRename2 _libdir ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed) + +rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a +rename newNameStr spans' a + = everywhere (mkT replaceRdr) a + where + newName = mkRdrUnqual (mkVarOcc newNameStr) + + cond :: SrcSpan -> Bool + cond ln = ss2range ln `elem` spans' + + replaceRdr :: LocatedN RdrName -> LocatedN RdrName + replaceRdr (L ln _) + | cond (locA ln) = L ln newName + replaceRdr x = x + +-- --------------------------------------------------------------------- + +changeWhereIn4 :: Changer +changeWhereIn4 _libdir ans parsed + = return (ans,everywhere (mkT replace) parsed) + where + replace :: LocatedN RdrName -> LocatedN RdrName + replace (L ln _n) + | ss2range (locA ln) == ((12,16),(12,17)) = L ln (mkRdrUnqual (mkVarOcc "p_2")) + replace x = x + +-- --------------------------------------------------------------------- + +changeLetIn1 :: Changer +changeLetIn1 _libdir ans parsed + = return (ans,everywhere (mkT replace) parsed) + where + replace :: HsExpr GhcPs -> HsExpr GhcPs + replace (HsLet (ApiAnn anc (AnnsLet l _i) cs) localDecls expr) + = + let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls + [l2,_l1] = map wrapDecl $ bagToList bagDecls + bagDecls' = listToBag $ concatMap decl2Bind [l2] + (L (SrcSpanAnn _ le) e) = expr + a = (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan le) (MovedAnchor (DP 0 1))) mempty noCom) le) + expr' = L a e + in (HsLet (ApiAnn anc (AnnsLet l (AD (DP 1 0))) cs) (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') + + replace x = x +-- --------------------------------------------------------------------- + +-- | Add a declaration to AddDecl +changeAddDecl1 :: Changer +changeAddDecl1 libdir ans top = do + Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") + let decl' = setEntryDP' decl (DP 2 0) + + let (p',(_,_),_) = runTransform mempty doAddDecl + doAddDecl = everywhereM (mkM replaceTopLevelDecls) top + replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource + replaceTopLevelDecls m = insertAtStart m decl' + return (ans,p') + +-- --------------------------------------------------------------------- +changeAddDecl2 :: Changer +changeAddDecl2 libdir ans top = do + Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") + let decl' = setEntryDP' decl (DP 2 0) + let top' = anchorEof top + + let (p',(_,_),_) = runTransform mempty doAddDecl + doAddDecl = everywhereM (mkM replaceTopLevelDecls) top' + replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource + replaceTopLevelDecls m = insertAtEnd m decl' + return (ans,p') + +-- --------------------------------------------------------------------- +changeAddDecl3 :: Changer +changeAddDecl3 libdir ans top = do + Right (_, decl) <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") + let decl' = setEntryDP' decl (DP 2 0) + + let (p',(_,_),_) = runTransform mempty doAddDecl + doAddDecl = everywhereM (mkM replaceTopLevelDecls) top + f d (l1:l2:ls) = l1:d:l2':ls + where + l2' = setEntryDP' l2 (DP 2 0) + replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource + replaceTopLevelDecls m = insertAt f m decl' + return (ans,p') + +-- --------------------------------------------------------------------- + +-- | Add a local declaration with signature to LocalDecl +changeLocalDecls :: Changer +changeLocalDecls libdir ans (L l p) = do + Right (_, s@(L ls (SigD _ sig))) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + Right (_, d@(L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + let decl' = setEntryDP' (L ld decl) (DP 1 0) + let sig' = setEntryDP' (L ls sig) (DP 0 0) + let (p',(_,_),_w) = runTransform mempty doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) p + replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) + -> Transform (LMatch GhcPs (LHsExpr GhcPs)) + replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do + let oldDecls = sortLocatedA $ map wrapDecl (bagToList binds) ++ map wrapSig sigs + let decls = s:d:oldDecls + let oldDecls' = captureLineSpacing oldDecls + let oldBinds = concatMap decl2Bind oldDecls' + (os:oldSigs) = concatMap decl2Sig oldDecls' + os' = setEntryDP' os (DP 2 0) + let sortKey = captureOrder decls + let (ApiAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van + let van' = (ApiAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DP 1 4)))) a b c dd) cs) + let binds' = (HsValBinds van' + (ValBinds sortKey (listToBag $ decl':oldBinds) + (sig':os':oldSigs))) + return (L lm (Match an mln pats (GRHSs noExtField rhs binds'))) + replaceLocalBinds x = return x + return (ans,L l p') + +-- --------------------------------------------------------------------- + +-- | Add a local declaration with signature to LocalDecl, where there was no +-- prior local decl. So it adds a "where" annotation. +changeLocalDecls2 :: Changer +changeLocalDecls2 libdir ans (L l p) = do + Right (_, d@(L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (_, s@(L ls (SigD _ sig))) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + let decl' = setEntryDP' (L ld decl) (DP 1 0) + let sig' = setEntryDP' (L ls sig) (DP 0 2) + let (p',(_,_),_w) = runTransform mempty doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) p + replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) + -> Transform (LMatch GhcPs (LHsExpr GhcPs)) + replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do + newSpan <- uniqueSrcSpanT + let anc = (Anchor (rs newSpan) (MovedAnchor (DP 1 2))) + let anc2 = (Anchor (rs newSpan) (MovedAnchor (DP 1 4))) + let an = ApiAnn anc + (AnnList (Just anc2) Nothing Nothing + [(undeltaSpan (rs newSpan) AnnWhere (DP 0 0))] []) + noCom + let decls = [s,d] + let sortKey = captureOrder decls + let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl']) + [sig'])) + return (L lm (Match ma mln pats (GRHSs noExtField rhs binds))) + replaceLocalBinds x = return x + return (ans,L l p') + +-- --------------------------------------------------------------------- + +-- | Check that balanceCommentsList is idempotent +changeWhereIn3a :: Changer +changeWhereIn3a _libdir ans (L l p) = do + let decls0 = hsmodDecls p + (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0) + (_de0:_:de1:_d2:_) = decls + debugM $ unlines w + debugM $ "changeWhereIn3a:de1:" ++ showAst de1 + let p2 = p { hsmodDecls = decls} + return (ans,L l p2) + +-- --------------------------------------------------------------------- + +changeWhereIn3b :: Changer +changeWhereIn3b _libdir ans (L l p) = do + let decls0 = hsmodDecls p + (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0) + (de0:_:de1:d2:_) = decls + de0' = setEntryDP' de0 (DP 2 0) + de1' = setEntryDP' de1 (DP 2 0) + d2' = setEntryDP' d2 (DP 2 0) + decls' = d2':de1':de0':(tail decls) + debugM $ unlines w + debugM $ "changeWhereIn3b:de1':" ++ showAst de1' + let p2 = p { hsmodDecls = decls'} + return (ans,L l p2) + +-- --------------------------------------------------------------------- + +addLocaLDecl1 :: Changer +addLocaLDecl1 libdir ans lp = do + Right (_, (L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + let decl' = setEntryDP' (L ld decl) (DP 1 4) + doAddLocal = do + (de1:d2:d3:_) <- hsDecls lp + (de1'',d2') <- balanceComments de1 d2 + (de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do + return ((wrapDecl decl' : d),Nothing) + replaceDecls lp [de1', d2', d3] + + (lp',(_,_),w) <- runTransformT mempty doAddLocal + debugM $ "addLocaLDecl1:" ++ intercalate "\n" w + return (ans,lp') + +-- --------------------------------------------------------------------- + +addLocaLDecl2 :: Changer +addLocaLDecl2 libdir ans lp = do + Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + let + doAddLocal = do + (de1:d2:_) <- hsDecls lp + (de1'',d2') <- balanceComments de1 d2 + + (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do + newDecl' <- transferEntryDP' d newDecl + let d' = setEntryDP' d (DP 1 0) + return ((newDecl':d':ds),Nothing) + + replaceDecls lp [parent',d2'] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +addLocaLDecl3 :: Changer +addLocaLDecl3 libdir ans lp = do + Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + -- Right (_, newDecl@(L ld (ValD _ decl))) <- withDynFlags libdir (\df -> parseDecl df "decl" "jj = 2") + let + doAddLocal = do + (de1:d2:_) <- hsDecls lp + (de1'',d2') <- balanceComments de1 d2 + + (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do + let newDecl' = setEntryDP' newDecl (DP 1 0) + return (((d:ds) ++ [newDecl']),Nothing) + + replaceDecls (anchorEof lp) [parent',d2'] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +addLocaLDecl4 :: Changer +addLocaLDecl4 libdir ans lp = do + Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") + Right (_, newSig) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") + -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp + let + doAddLocal = do + (parent:ds) <- hsDecls lp + + let newDecl' = setEntryDP' newDecl (DP 1 0) + let newSig' = setEntryDP' newSig (DP 1 4) + + (parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do + return ((decls++[newSig',newDecl']),Nothing) + + replaceDecls (anchorEof lp) (parent':ds) + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + + +-- --------------------------------------------------------------------- + +addLocaLDecl5 :: Changer +addLocaLDecl5 _libdir ans lp = do + let + doAddLocal = do + decls <- hsDecls lp + [s1,de1,d2,d3] <- balanceCommentsList decls + + let d3' = setEntryDP' d3 (DP 2 0) + + (de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do + let d2' = setEntryDP' d2 (DP 1 0) + return ([d2'],Nothing) + replaceDecls lp [s1,de1',d3'] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +addLocaLDecl6 :: Changer +addLocaLDecl6 libdir ans lp = do + Right (_, newDecl) <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") + let + newDecl' = setEntryDP' newDecl (DP 1 4) + doAddLocal = do + decls0 <- hsDecls lp + [de1'',d2] <- balanceCommentsList decls0 + + let de1 = captureMatchLineSpacing de1'' + let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms) _) _)) = de1 + let [ma1,_ma2] = ms + + (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do + return ((newDecl' : decls),Nothing) + replaceDecls lp [de1', d2] + + (lp',(_,_),_w) <- runTransformT mempty doAddLocal + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmDecl1 :: Changer +rmDecl1 _libdir ans lp = do + let doRmDecl = do + tlDecs0 <- hsDecls lp + tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0 + let (de1:_s1:_d2:ds) = tlDecs + + replaceDecls lp (de1:ds) + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmDecl2 :: Changer +rmDecl2 _libdir ans lp = do + let + doRmDecl = do + let + go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs) + go e@(GHC.L _ (GHC.HsLet{})) = do + decs0 <- hsDecls e + decs <- balanceCommentsList $ captureLineSpacing decs0 + e' <- replaceDecls e (init decs) + return e' + go x = return x + + everywhereM (mkM go) lp + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmDecl3 :: Changer +rmDecl3 _libdir ans lp = do + let + doRmDecl = do + [de1,d2] <- hsDecls lp + + (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do + let sd1' = setEntryDP' sd1 (DP 2 0) + return ([],Just sd1') + + replaceDecls lp [de1',sd1,d2] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmDecl4 :: Changer +rmDecl4 _libdir ans lp = do + let + doRmDecl = do + [de1] <- hsDecls lp + + (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do + sd2' <- transferEntryDP' sd1 sd2 + + let sd1' = setEntryDP' sd1 (DP 2 0) + return ([sd2'],Just sd1') + + replaceDecls (anchorEof lp) [de1',sd1] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmDecl5 :: Changer +rmDecl5 _libdir ans lp = do + let + doRmDecl = do + let + go :: HsExpr GhcPs -> Transform (HsExpr GhcPs) + go (HsLet a lb expr) = do + decs <- hsDeclsValBinds lb + let dec = last decs + _ <- transferEntryDPT (head decs) dec + lb' <- replaceDeclsValbinds WithoutWhere lb [dec] + return (HsLet a lb' expr) + go x = return x + + everywhereM (mkM go) lp + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmDecl6 :: Changer +rmDecl6 _libdir ans lp = do + let + doRmDecl = do + [de1] <- hsDecls lp + + (de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do + let (ss1:_sd1:sd2:sds) = subDecs + sd2' <- transferEntryDP' ss1 sd2 + + return (sd2':sds,Nothing) + + replaceDecls lp [de1'] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmDecl7 :: Changer +rmDecl7 _libdir ans lp = do + let + doRmDecl = do + tlDecs <- hsDecls lp + [s1,de1,d2,d3] <- balanceCommentsList tlDecs + + d3' <- transferEntryDP' d2 d3 + + replaceDecls lp [s1,de1,d3'] + + (lp',(_,_),_w) <- runTransformT mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmTypeSig1 :: Changer +rmTypeSig1 _libdir ans lp = do + let doRmDecl = do + tlDecs <- hsDecls lp + let (s0:de1:d2) = tlDecs + s1 = captureTypeSigSpacing s0 + (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1 + n2' <- transferEntryDP n1 n2 + let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ))) + replaceDecls lp (s1':de1:d2) + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +rmTypeSig2 :: Changer +rmTypeSig2 _libdir ans lp = do + let doRmDecl = do + tlDecs <- hsDecls lp + let [de1] = tlDecs + + (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do + d' <- transferEntryDPT s d + return ([d'],Nothing) + replaceDecls lp [de1'] + + let (lp',(_,_),_w) = runTransform mempty doRmDecl + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +addHiding1 :: Changer +addHiding1 _libdir ans (L l p) = do + let doTransform = do + l0 <- uniqueSrcSpanT + l1 <- uniqueSrcSpanT + l2 <- uniqueSrcSpanT + let + [L li imp1,imp2] = hsmodImports p + n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) + n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2))) + impHiding = L (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan l0) m0) + (AnnList Nothing + (Just (AddApiAnn AnnOpenP d1)) + (Just (AddApiAnn AnnCloseP d0)) + [(AddApiAnn AnnHiding d1)] + []) + noCom) l0) [v1,v2] + imp1' = imp1 { ideclHiding = Just (True,impHiding)} + p' = p { hsmodImports = [L li imp1',imp2]} + return (L l p') + + let (lp',(_ans',_),_w) = runTransform mempty doTransform + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + +-- --------------------------------------------------------------------- + +addHiding2 :: Changer +addHiding2 _libdir ans (L l p) = do + let doTransform = do + l1 <- uniqueSrcSpanT + l2 <- uniqueSrcSpanT + let + [L li imp1] = hsmodImports p + Just (_,L lh ns) = ideclHiding imp1 + lh' = (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan (locA lh)) m0) + (AnnList Nothing + (Just (AddApiAnn AnnOpenP d1)) + (Just (AddApiAnn AnnCloseP d0)) + [(AddApiAnn AnnHiding d1)] + []) + noCom) (locA lh)) + n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) + n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2))) + L ln n = last ns + n' = L (addComma ln) n + imp1' = imp1 { ideclHiding = Just (True,L lh' (init ns ++ [n',v1,v2]))} + p' = p { hsmodImports = [L li imp1']} + return (L l p') + + let (lp',(_ans',_),_w) = runTransform mempty doTransform + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (ans,lp') + + +-- --------------------------------------------------------------------- +-- From SYB + +-- | Apply transformation on each level of a tree. +-- +-- Just like 'everything', this is stolen from SYB package. +everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a) +everywhere f = f . gmapT (everywhere f) + +-- | Create generic transformation. +-- +-- Another function stolen from SYB package. +mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a) +mkT f = case cast f of + Just f' -> f' + Nothing -> id + +-- --------------------------------------------------------------------- diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs new file mode 100644 index 0000000000..2901356879 --- /dev/null +++ b/utils/check-exact/Transform.hs @@ -0,0 +1,1513 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.GHC.ExactPrint.Transform +-- +-- This module is currently under heavy development, and no promises are made +-- about API stability. Use with care. +-- +-- We welcome any feedback / contributions on this, as it is the main point of +-- the library. +-- +----------------------------------------------------------------------------- +module Transform + ( + -- * The Transform Monad + Transform + , TransformT(..) + , hoistTransform + , runTransform + , runTransformT + , runTransformFrom + , runTransformFromT + + -- * Transform monad operations + , logTr + , logDataWithAnnsTr + , getAnnsT, putAnnsT, modifyAnnsT + , uniqueSrcSpanT + + , cloneT + , graftT + + , getEntryDPT + , setEntryDPT + , transferEntryDPT + , setPrecedingLinesDeclT + , setPrecedingLinesT + , addSimpleAnnT + , addTrailingCommaT + , removeTrailingCommaT + + -- ** Managing declarations, in Transform monad + , HasTransform (..) + , HasDecls (..) + , hasDeclsSybTransform + , hsDeclsGeneric + , hsDeclsPatBind, hsDeclsPatBindD + , replaceDeclsPatBind, replaceDeclsPatBindD + , modifyDeclsT + , modifyValD + -- *** Utility, does not manage layout + , hsDeclsValBinds, replaceDeclsValbinds + , WithWhere(..) + + -- ** New gen functions + , noAnnSrcSpanDP + , noAnnSrcSpanDP0 + , noAnnSrcSpanDP1 + , noAnnSrcSpanDPn + , d0, d1, dn + , m0, m1, mn + , addComma + + -- ** Managing lists, Transform monad + , insertAt + , insertAtStart + , insertAtEnd + , insertAfter + , insertBefore + + -- *** Low level operations used in 'HasDecls' + , balanceComments + , balanceCommentsList + , balanceCommentsList' + , balanceTrailingComments + , moveTrailingComments + , anchorEof + + -- ** Managing lists, pure functions + , captureOrder + , captureLineSpacing + , captureMatchLineSpacing + , captureTypeSigSpacing + + -- * Operations + , isUniqueSrcSpan + + -- * Pure functions + , mergeAnns + , mergeAnnList + , setPrecedingLinesDecl + , setPrecedingLines + , getEntryDP + , setEntryDP + , setEntryDP' + , transferEntryDP + , transferEntryDP' + , addTrailingComma + , wrapSig, wrapDecl + , decl2Sig, decl2Bind + , deltaAnchor + ) where + +import Types +import Utils + +import Control.Monad.RWS +import qualified Control.Monad.Fail as Fail + +import GHC hiding (parseModule, parsedSource) +import GHC.Data.Bag +import GHC.Data.FastString + +-- import qualified Data.Generics as SYB + +import Data.Data +import Data.List +import Data.Maybe + +import qualified Data.Map as Map + +import Data.Functor.Identity +import Control.Monad.State +import Control.Monad.Writer + +-- import Debug.Trace + +------------------------------------------------------------------------------ +-- Transformation of source elements + +-- | Monad type for updating the AST and managing the annotations at the same +-- time. The W state is used to generate logging information if required. +type Transform = TransformT Identity + +-- |Monad transformer version of 'Transform' monad +newtype TransformT m a = TransformT { unTransformT :: RWST () [String] (Anns,Int) m a } + deriving (Monad,Applicative,Functor + ,MonadReader () + ,MonadWriter [String] + ,MonadState (Anns,Int) + ,MonadTrans + ) + +instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where + fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg + +-- | Run a transformation in the 'Transform' monad, returning the updated +-- annotations and any logging generated via 'logTr' +runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String]) +runTransform ans f = runTransformFrom 0 ans f + +runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String]) +runTransformT ans f = runTransformFromT 0 ans f + +-- | Run a transformation in the 'Transform' monad, returning the updated +-- annotations and any logging generated via 'logTr', allocating any new +-- SrcSpans from the provided initial value. +runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String]) +runTransformFrom seed ans f = runRWS (unTransformT f) () (ans,seed) + +-- |Run a monad transformer stack for the 'TransformT' monad transformer +runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String]) +runTransformFromT seed ans f = runRWST (unTransformT f) () (ans,seed) + +-- | Change inner monad of 'TransformT'. +hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a +hoistTransform nt (TransformT m) = TransformT (mapRWST nt m) + +-- |Log a string to the output of the Monad +logTr :: (Monad m) => String -> TransformT m () +logTr str = tell [str] + +-- |Log a representation of the given AST with annotations to the output of the +-- Monad +logDataWithAnnsTr :: (Monad m) => (Data a) => String -> a -> TransformT m () +logDataWithAnnsTr str ast = do + logTr $ str ++ showAst ast + +-- |Access the 'Anns' being modified in this transformation +getAnnsT :: (Monad m) => TransformT m Anns +getAnnsT = gets fst + +-- |Replace the 'Anns' after any changes +putAnnsT :: (Monad m) => Anns -> TransformT m () +putAnnsT ans = do + (_,col) <- get + put (ans,col) + +-- |Change the stored 'Anns' +modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m () +modifyAnnsT f = do + ans <- getAnnsT + putAnnsT (f ans) + +-- --------------------------------------------------------------------- + +-- |Once we have 'Anns', a 'SrcSpan' is used purely as part of an 'AnnKey' +-- to index into the 'Anns'. If we need to add new elements to the AST, they +-- need their own 'SrcSpan' for this. +uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan +uniqueSrcSpanT = do + (an,col) <- get + put (an,col + 1 ) + let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col + return $ mkSrcSpan pos pos + +-- |Test whether a given 'SrcSpan' was generated by 'uniqueSrcSpanT' +isUniqueSrcSpan :: SrcSpan -> Bool +isUniqueSrcSpan ss = srcSpanStartLine' ss == -1 + +srcSpanStartLine' :: SrcSpan -> Int +srcSpanStartLine' (RealSrcSpan s _) = srcSpanStartLine s +srcSpanStartLine' _ = 0 + +-- --------------------------------------------------------------------- +-- |Make a copy of an AST element, replacing the existing SrcSpans with new +-- ones, and duplicating the matching annotations. +cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(SrcSpan, SrcSpan)]) +cloneT ast = do + runWriterT $ everywhereM (return `ext2M` replaceLocated) ast + where + replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m) + => (GenLocated loc a) -> WriterT [(SrcSpan, SrcSpan)] (TransformT m) (GenLocated loc a) + replaceLocated (L l t) = do + case cast l :: Maybe SrcSpan of + Just ss -> do + newSpan <- lift uniqueSrcSpanT + lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) anns of + Nothing -> anns + Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns) + tell [(ss, newSpan)] + return $ fromJust . cast $ L newSpan t + Nothing -> return (L l t) + +-- --------------------------------------------------------------------- +-- |Slightly more general form of cloneT +graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a +graftT origAnns = everywhereM (return `ext2M` replaceLocated) + where + replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m) + => GenLocated loc a -> TransformT m (GenLocated loc a) + replaceLocated (L l t) = do + case cast l :: Maybe SrcSpan of + Just ss -> do + newSpan <- uniqueSrcSpanT + modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (L ss t)) origAnns of + Nothing -> anns + Just an -> Map.insert (mkAnnKey (L newSpan t)) an anns) + return $ fromJust $ cast $ L newSpan t + Nothing -> return (L l t) + +-- --------------------------------------------------------------------- + +-- |If a list has been re-ordered or had items added, capture the new order in +-- the appropriate 'AnnSortKey' attached to the 'Annotation' for the list. +captureOrder :: [LocatedA b] -> AnnSortKey +captureOrder ls = AnnSortKey $ map (rs . getLocA) ls + +-- --------------------------------------------------------------------- + +captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs +captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ) e) f))) + = L l (ValD x (FunBind a b (MG c (L d ms') e) f)) + where + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = captureLineSpacing ms +captureMatchLineSpacing d = d + +captureLineSpacing :: Monoid t + => [LocatedAn t e] -> [GenLocated (SrcSpanAnn' (ApiAnn' t)) e] +captureLineSpacing [] = [] +captureLineSpacing [d] = [d] +captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds) + where + (l1,_) = ss2pos $ rs $ getLocA de1 + (l2,_) = ss2pos $ rs $ getLocA d2 + d2' = setEntryDP' d2 (DP (l2-l1) 0) + +-- --------------------------------------------------------------------- + +captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs +captureTypeSigSpacing (L l (SigD x (TypeSig (ApiAnn anc (AnnSig dc rs') cs) ns (HsWC xw ty)))) + = (L l (SigD x (TypeSig (ApiAnn anc (AnnSig dc' rs') cs) ns (HsWC xw ty')))) + where + -- we want DPs for the distance from the end of the ns to the + -- AnnDColon, and to the start of the ty + AddApiAnn kw dca = dc + rd = case last ns of + L (SrcSpanAnn ApiAnnNotUsed ll) _ -> realSrcSpan ll + L (SrcSpanAnn (ApiAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? + -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r + dc' = case dca of + AR r -> AddApiAnn kw (AD $ ss2delta (ss2posEnd rd) r) + AD _ -> AddApiAnn kw dca + + -- --------------------------------- + + ty' :: LHsSigType GhcPs + ty' = case ty of + (L (SrcSpanAnn ApiAnnNotUsed ll) b) + -> let + op = case dca of + AR r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) + AD _ -> MovedAnchor (DP 0 1) + in (L (SrcSpanAnn (ApiAnn (Anchor (realSrcSpan ll) op) mempty noCom) ll) b) + (L (SrcSpanAnn (ApiAnn (Anchor r op) a c) ll) b) + -> let + op' = case op of + MovedAnchor _ -> op + _ -> case dca of + AR dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r) + AD _ -> MovedAnchor (DP 0 1) + in (L (SrcSpanAnn (ApiAnn (Anchor r op') a c) ll) b) + +captureTypeSigSpacing s = s + +-- --------------------------------------------------------------------- + +-- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does +-- nothing to any annotations that may be attached to either of the elements. +-- It is used as a utility function in 'replaceDecls' +decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs] +decl2Bind (L l (ValD _ s)) = [L l s] +decl2Bind _ = [] + +-- |Pure function to convert a 'LSig' to a 'LHsBind'. This does +-- nothing to any annotations that may be attached to either of the elements. +-- It is used as a utility function in 'replaceDecls' +decl2Sig :: LHsDecl GhcPs -> [LSig GhcPs] +decl2Sig (L l (SigD _ s)) = [L l s] +decl2Sig _ = [] + +-- --------------------------------------------------------------------- + +-- |Convert a 'LSig' into a 'LHsDecl' +wrapSig :: LSig GhcPs -> LHsDecl GhcPs +wrapSig (L l s) = L l (SigD NoExtField s) + +-- --------------------------------------------------------------------- + +-- |Convert a 'LHsBind' into a 'LHsDecl' +wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs +wrapDecl (L l s) = L l (ValD NoExtField s) + +-- --------------------------------------------------------------------- + +-- |Create a simple 'Annotation' without comments, and attach it to the first +-- parameter. +addSimpleAnnT :: (Data a,Monad m) + => Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () +addSimpleAnnT ast dp kds = do + let ann = annNone { annEntryDelta = dp + , annsDP = kds + } + modifyAnnsT (Map.insert (mkAnnKey ast) ann) + +-- --------------------------------------------------------------------- + +-- |Add a trailing comma annotation, unless there is already one +addTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m () +addTrailingCommaT ast = do + modifyAnnsT (addTrailingComma ast (DP 0 0)) + +-- --------------------------------------------------------------------- + +-- |Remove a trailing comma annotation, if there is one one +removeTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m () +removeTrailingCommaT ast = do + modifyAnnsT (removeTrailingComma ast) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'getEntryDP' +getEntryDPT :: (Data a,Monad m) => Located a -> TransformT m DeltaPos +getEntryDPT ast = do + anns <- getAnnsT + return (getEntryDP anns ast) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'getEntryDP' +setEntryDPT :: (Data a,Monad m) => LocatedA a -> DeltaPos -> TransformT m () +setEntryDPT ast dp = do + modifyAnnsT (setEntryDP ast dp) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'transferEntryDP' +transferEntryDPT :: (Data a,Data b,Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA b) +transferEntryDPT _a b = do + return b + -- modifyAnnsT (transferEntryDP a b) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'setPrecedingLinesDecl' +setPrecedingLinesDeclT :: (Monad m) => LHsDecl GhcPs -> Int -> Int -> TransformT m () +setPrecedingLinesDeclT ld n c = + modifyAnnsT (setPrecedingLinesDecl ld n c) + +-- --------------------------------------------------------------------- + +-- |'Transform' monad version of 'setPrecedingLines' +setPrecedingLinesT :: (Data a,Monad m) => LocatedA a -> Int -> Int -> TransformT m () +setPrecedingLinesT ld n c = + modifyAnnsT (setPrecedingLines ld n c) + +-- --------------------------------------------------------------------- + +-- | Left bias pair union +mergeAnns :: Anns -> Anns -> Anns +mergeAnns + = Map.union + +-- |Combine a list of annotations +mergeAnnList :: [Anns] -> Anns +mergeAnnList [] = error "mergeAnnList must have at lease one entry" +mergeAnnList (x:xs) = foldr mergeAnns x xs + +-- --------------------------------------------------------------------- + +-- |Unwrap a HsDecl and call setPrecedingLines on it +-- ++AZ++ TODO: get rid of this, it is a synonym only +setPrecedingLinesDecl :: LHsDecl GhcPs -> Int -> Int -> Anns -> Anns +setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans + +-- --------------------------------------------------------------------- + +-- | Adjust the entry annotations to provide an `n` line preceding gap +setPrecedingLines :: (Data a) => LocatedA a -> Int -> Int -> Anns -> Anns +setPrecedingLines ast n c anne = setEntryDP ast (DP n c) anne + +-- --------------------------------------------------------------------- + +-- |Return the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +getEntryDP :: (Data a) => Anns -> Located a -> DeltaPos +getEntryDP anns ast = + case Map.lookup (mkAnnKey ast) anns of + Nothing -> DP 0 0 + Just ann -> annTrueEntryDelta ann + +-- --------------------------------------------------------------------- + +setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs +setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ) e) f))) dp + = L l' (ValD x (FunBind a b (MG c (L d ms') e) f)) + where + L l' _ = setEntryDP' decl dp + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = case ms of + [] -> [] + (m0':ms0) -> setEntryDP' m0' dp : ms0 +setEntryDPDecl d dp = setEntryDP' d dp + +-- --------------------------------------------------------------------- + +-- |Set the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +-- setEntryDP' :: (Data a) => LocatedA a -> DeltaPos -> LocatedA a +setEntryDP' :: (Monoid t) => LocatedAn t a -> DeltaPos -> LocatedAn t a +setEntryDP' (L (SrcSpanAnn ApiAnnNotUsed l) a) dp + = L (SrcSpanAnn + (ApiAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty noCom) + l) a +setEntryDP' (L (SrcSpanAnn (ApiAnn (Anchor r _) an (AnnComments [])) l) a) dp + = L (SrcSpanAnn + (ApiAnn (Anchor r (MovedAnchor dp)) an (AnnComments [])) + l) a +setEntryDP' (L (SrcSpanAnn (ApiAnn (Anchor r _) an cs) l) a) dp + = case sort (priorComments cs) of + [] -> + L (SrcSpanAnn + (ApiAnn (Anchor r (MovedAnchor dp)) an cs) + l) a + (L ca c:cs') -> + L (SrcSpanAnn + (ApiAnn (Anchor r (MovedAnchor edp)) an cs'') + l) a + where + cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs') + lc = head $ reverse $ (L ca c:cs') + DP line col = ss2delta (ss2pos $ anchor $ getLoc lc) r + -- TODO: this adjustment by 1 happens all over the place. Generalise it + edp' = if line == 0 then DP line col + else DP line (col - 1) + edp = edp' `debug` ("setEntryDP' :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r)) + -- edp = if line == 0 then DP (line, col) + -- else DP (line, col - 1) + +-- |Set the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +setEntryDP :: (Data a) => LocatedA a -> DeltaPos -> Anns -> Anns +setEntryDP _ast _dp anns = anns + +-- --------------------------------------------------------------------- + +addAnnAnchorDelta :: LayoutStartCol -> RealSrcSpan -> AnnAnchor -> AnnAnchor +addAnnAnchorDelta _off _anc (AD d) = AD d +addAnnAnchorDelta off anc (AR r) + = AD (adjustDeltaForOffset 0 off (ss2deltaEnd anc r)) + +-- Set the entry DP for an element coming after an existing keyword annotation +setEntryDPFromAnchor :: LayoutStartCol -> AnnAnchor -> LocatedA t -> LocatedA t +setEntryDPFromAnchor _off (AD _) (L la a) = L la a +setEntryDPFromAnchor off (AR anc) ll@(L la _) = setEntryDP' ll dp' + where + r = case la of + (SrcSpanAnn ApiAnnNotUsed l) -> realSrcSpan l + (SrcSpanAnn (ApiAnn (Anchor r' _) _ _) _) -> r' + dp' = adjustDeltaForOffset 0 off (ss2deltaEnd anc r) + +-- --------------------------------------------------------------------- + +-- -- |When setting an entryDP, the leading comment needs to be adjusted too +-- setCommentEntryDP :: Annotation -> DeltaPos -> Annotation +-- -- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann' +-- setCommentEntryDP ann dp = ann' +-- where +-- ann' = case (annPriorComments ann) of +-- [] -> ann +-- [(pc,_)] -> ann { annPriorComments = [(pc,dp)] } +-- ((pc,_):pcs) -> ann { annPriorComments = ((pc,dp):pcs) } + +-- --------------------------------------------------------------------- + +-- |Take the annEntryDelta associated with the first item and associate it with the second. +-- Also transfer any comments occuring before it. +transferEntryDP :: (Monad m, Monoid t) => LocatedAn t a -> LocatedAn t b -> TransformT m (LocatedAn t b) +transferEntryDP (L (SrcSpanAnn ApiAnnNotUsed l1) _) (L (SrcSpanAnn ApiAnnNotUsed _) b) = do + logTr $ "transferEntryDP': ApiAnnNotUsed,ApiAnnNotUsed" + return (L (SrcSpanAnn ApiAnnNotUsed l1) b) +transferEntryDP (L (SrcSpanAnn (ApiAnn anc _an cs) _l1) _) (L (SrcSpanAnn ApiAnnNotUsed l2) b) = do + logTr $ "transferEntryDP': ApiAnn,ApiAnnNotUsed" + return (L (SrcSpanAnn (ApiAnn anc mempty cs) l2) b) +transferEntryDP (L (SrcSpanAnn (ApiAnn anc1 _an1 cs1) _l1) _) (L (SrcSpanAnn (ApiAnn _anc2 an2 cs2) l2) b) = do + logTr $ "transferEntryDP': ApiAnn,ApiAnn" + -- Problem: if the original had preceding comments, blindly + -- transferring the location is not correct + case priorComments cs1 of + [] -> return (L (SrcSpanAnn (ApiAnn anc1 an2 cs2) l2) b) + -- TODO: what happens if the receiving side already has comments? + (L anc _:_) -> do + logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc + return (L (SrcSpanAnn (ApiAnn (kludgeAnchor anc) an2 cs2) l2) b) +transferEntryDP (L (SrcSpanAnn ApiAnnNotUsed _l1) _) (L (SrcSpanAnn (ApiAnn anc2 an2 cs2) l2) b) = do + logTr $ "transferEntryDP': ApiAnnNotUsed,ApiAnn" + return (L (SrcSpanAnn (ApiAnn anc2' an2 cs2) l2) b) + where + anc2' = case anc2 of + Anchor _a op -> Anchor (realSrcSpan l2) op + +-- |Take the annEntryDelta associated with the first item and associate it with the second. +-- Also transfer any comments occuring before it. +-- TODO: call transferEntryDP, and use pushDeclDP +transferEntryDP' :: (Monad m) => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs) +transferEntryDP' la lb = do + (L l2 b) <- transferEntryDP la lb + return (L l2 (pushDeclDP b (DP 0 0))) + +-- There is an off-by-one in DPs. I *think* it has to do wether we +-- calculate the final position when applying it against the stored +-- final pos or against another RealSrcSpan. Must get to the bottom +-- of it and come up with a canonical DP. This function adjusts a +-- "comment space" DP to a "enterAnn" space one +kludgeAnchor :: Anchor -> Anchor +kludgeAnchor a@(Anchor _ (MovedAnchor (DP 0 _))) = a +kludgeAnchor (Anchor a (MovedAnchor (DP r c))) = (Anchor a (MovedAnchor (DP r (c - 1)))) +kludgeAnchor a = a + +pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs +pushDeclDP (ValD x (FunBind a b (MG c (L d ms ) e) f)) dp + = ValD x (FunBind a b (MG c (L d' ms') e) f) + where + L d' _ = setEntryDP' (L d ms) dp + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = case ms of + [] -> [] + (m0':ms0) -> setEntryDP' m0' dp : ms0 +pushDeclDP d _dp = d + +-- --------------------------------------------------------------------- + +addTrailingComma :: (Data a) => Located a -> DeltaPos -> Anns -> Anns +addTrailingComma a dp anns = + case Map.lookup (mkAnnKey a) anns of + Nothing -> anns + Just an -> + case find isAnnComma (annsDP an) of + Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G AnnComma,dp)]}) anns + Just _ -> anns + where + isAnnComma (G AnnComma,_) = True + isAnnComma _ = False + +-- --------------------------------------------------------------------- + +removeTrailingComma :: (Data a) => Located a -> Anns -> Anns +removeTrailingComma a anns = + case Map.lookup (mkAnnKey a) anns of + Nothing -> anns + Just an -> + case find isAnnComma (annsDP an) of + Nothing -> anns + Just _ -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns + where + isAnnComma (G AnnComma,_) = True + isAnnComma _ = False + +-- --------------------------------------------------------------------- + +balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] +balanceCommentsList [] = return [] +balanceCommentsList [x] = return [x] +balanceCommentsList (a:b:ls) = do + (a',b') <- balanceComments a b + r <- balanceCommentsList (b':ls) + return (a':r) + +-- |The relatavise phase puts all comments appearing between the end of one AST +-- item and the beginning of the next as 'annPriorComments' for the second one. +-- This function takes two adjacent AST items and moves any 'annPriorComments' +-- from the second one to the 'annFollowingComments' of the first if they belong +-- to it instead. This is typically required before deleting or duplicating +-- either of the AST elements. +balanceComments :: (Monad m) + => LHsDecl GhcPs -> LHsDecl GhcPs + -> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs) +balanceComments first second = do + -- ++AZ++ : replace the nested casts with appropriate gmapM + -- logTr $ "balanceComments entered" + -- logDataWithAnnsTr "first" first + case first of + (L l (ValD x fb@(FunBind{}))) -> do + (L l' fb',second') <- balanceCommentsFB (L l fb) second + return (L l' (ValD x fb'), second') + _ -> balanceComments' first second + +-- |Once 'balanceComments' has been called to move trailing comments to a +-- 'FunBind', these need to be pushed down from the top level to the last +-- 'Match' if that 'Match' needs to be manipulated. +balanceCommentsFB :: (Data b,Monad m) + => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) +balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do + logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) + matches' <- balanceCommentsList' matches + let (m,ms) = case reverse matches' of + (m':ms') -> (m',ms') + _ -> error "balanceCommentsFB" + (m',second') <- balanceComments' m second + m'' <- balanceCommentsMatch m' + logTr $ "balanceCommentsMatch done" + return (L lf (FunBind x n (MG mx (L lm (reverse (m'':ms))) o) t), second') +balanceCommentsFB f s = balanceComments' f s + +-- | Move comments on the same line as the end of the match into the +-- GRHS, prior to the binds +balanceCommentsMatch :: (Monad m) + => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) +balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do + logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l)) + logTr $ "balanceCommentsMatch: (move',stay')=" ++ showAst (move',stay') + logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo) + logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l)) + logTr $ "balanceCommentsMatch: (anc1,cs1f)=" ++ showAst (anc1,cs1f) + logTr $ "balanceCommentsMatch: (l'', grhss')=" ++ showAst (l'', grhss') + return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) + where + simpleBreak (r,_) = r /= 0 + (SrcSpanAnn an1 _loc1) = l + anc1 = addCommentOrigDeltas $ apiAnnComments an1 + cs1f = getFollowingComments anc1 + -- (move',stay') = break simpleBreak (commentsDeltas (anchorFromLocatedA (L l ())) cs1f) + (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f) + move = map snd move' + stay = map snd stay' + (l'', grhss', binds', logInfo) + = case reverse grhss of + [] -> (l, [], binds, (AnnComments [], SrcSpanAnn ApiAnnNotUsed noSrcSpan)) + (L lg g@(GRHS ApiAnnNotUsed _grs _rhs):gs) -> (l, reverse (L lg g:gs), binds, (AnnComments [], SrcSpanAnn ApiAnnNotUsed noSrcSpan)) + (L lg (GRHS ag grs rhs):gs) -> + let + anc1' = setFollowingComments anc1 stay + an1' = setCommentsSrcAnn l anc1' + + -- --------------------------------- + (moved,bindsm) = pushTrailingComments WithWhere (AnnCommentsBalanced [] move) binds + -- --------------------------------- + + (ApiAnn anc an lgc) = ag + lgc' = splitComments (realSrcSpan lg) $ addCommentOrigDeltas lgc + ag' = if moved + then ApiAnn anc an lgc' + else ApiAnn anc an (lgc' <> (AnnCommentsBalanced [] move)) + -- ag' = ApiAnn anc an lgc' + + in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1')) + +pushTrailingComments :: WithWhere -> ApiAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs) +pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b) +pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:HsIPBinds" +pushTrailingComments w cs lb@(HsValBinds an _) + = (True, HsValBinds an' vb) + where + (decls, _, _ws1) = runTransform mempty (hsDeclsValBinds lb) + (an', decls') = case reverse decls of + [] -> (addCommentsToApiAnn (spanHsLocaLBinds lb) an cs, decls) + (L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds) + (vb,_ws2) = case runTransform mempty (replaceDeclsValbinds w lb decls') of + ((HsValBinds _ vb'), _, ws2') -> (vb', ws2') + _ -> (ValBinds NoAnnSortKey emptyBag [], []) + + +balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a] +balanceCommentsList' [] = return [] +balanceCommentsList' [x] = return [x] +balanceCommentsList' (a:b:ls) = do + logTr $ "balanceCommentsList' entered" + (a',b') <- balanceComments' a b + r <- balanceCommentsList' (b':ls) + return (a':r) + +-- |Prior to moving an AST element, make sure any trailing comments belonging to +-- it are attached to it, and not the following element. Of necessity this is a +-- heuristic process, to be tuned later. Possibly a variant should be provided +-- with a passed-in decision function. +-- The initial situation is that all comments for a given anchor appear as prior comments +-- Many of these should in fact be following comments for the previous anchor +balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) +balanceComments' la1 la2 = do + logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) + logTr $ "balanceComments': (anchorFromLocatedA la1)=" ++ showGhc (anchorFromLocatedA la1) + logTr $ "balanceComments': (sort cs2b)=" ++ showAst (sort cs2b) + logTr $ "balanceComments': (move',stay')=" ++ showAst (move',stay') + logTr $ "balanceComments': (move'',stay'')=" ++ showAst (move'',stay'') + logTr $ "balanceComments': (move,stay)=" ++ showAst (move,stay) + return (la1', la2') + where + simpleBreak n (r,_) = r > n + L (SrcSpanAnn an1 loc1) f = la1 + L (SrcSpanAnn an2 loc2) s = la2 + anc1 = addCommentOrigDeltas $ apiAnnComments an1 + anc2 = addCommentOrigDeltas $ apiAnnComments an2 + cs1f = getFollowingComments anc1 + cs2b = priorComments anc2 + (stay'',move') = break (simpleBreak 1) (priorCommentsDeltas (anchorFromLocatedA la2) cs2b) + -- Need to also check for comments more closely attached to la1, + -- ie trailing on the same line + (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay'')) + move = map snd (move'' ++ move') + stay = map snd stay' + cs1 = setFollowingComments anc1 (sort $ cs1f ++ move) + cs2 = setPriorComments anc2 stay + + an1' = setCommentsSrcAnn (getLoc la1) cs1 + an2' = setCommentsSrcAnn (getLoc la2) cs2 + la1' = L an1' f + la2' = L an2' s + +-- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start +trailingCommentsDeltas :: RealSrcSpan -> [LAnnotationComment] + -> [(Int, LAnnotationComment)] +trailingCommentsDeltas _ [] = [] +trailingCommentsDeltas anc (la@(L l _):las) + = deltaComment anc la : trailingCommentsDeltas (anchor l) las + where + deltaComment anc' (L loc c) = (abs(ll - al), L loc c) + where + (al,_) = ss2posEnd anc' + (ll,_) = ss2pos (anchor loc) + +-- AZ:TODO: this is identical to commentsDeltas +priorCommentsDeltas :: RealSrcSpan -> [LAnnotationComment] + -> [(Int, LAnnotationComment)] +priorCommentsDeltas anc cs = go anc (reverse $ sort cs) + where + go :: RealSrcSpan -> [LAnnotationComment] -> [(Int, LAnnotationComment)] + go _ [] = [] + go anc' (la@(L l _):las) = deltaComment anc' la : go (anchor l) las + + deltaComment :: RealSrcSpan -> LAnnotationComment -> (Int, LAnnotationComment) + deltaComment anc' (L loc c) = (abs(ll - al), L loc c) + where + (al,_) = ss2pos anc' + (ll,_) = ss2pos (anchor loc) + + +-- | Split comments into ones occuring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> ApiAnnComments -> ApiAnnComments +splitComments p (AnnComments cs) = cs' + where + cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p + (before, after) = break cmp cs + cs' = case after of + [] -> AnnComments cs + _ -> AnnCommentsBalanced before after +splitComments p (AnnCommentsBalanced cs ts) = AnnCommentsBalanced cs' ts' + where + cmp (L (Anchor l _) _) = ss2pos l < ss2posEnd p + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | A GHC comment includes the span of the preceding (non-comment) +-- token. Takes an original list of comments, and converts the +-- 'Anchor's to have a have a `MovedAnchor` operation based on the +-- original locations. +commentOrigDeltas :: [LAnnotationComment] -> [LAnnotationComment] +commentOrigDeltas [] = [] +commentOrigDeltas lcs@(L _ (GHC.AnnComment _ pt):_) = go pt lcs + -- TODO:AZ: we now have deltas wrt *all* tokens, not just preceding + -- non-comment. Simplify this. + where + go :: RealSrcSpan -> [LAnnotationComment] -> [LAnnotationComment] + go _ [] = [] + go p (L (Anchor la _) (GHC.AnnComment t pp):ls) + = L (Anchor la op) (GHC.AnnComment t pp) : go p' ls + where + p' = p + (r,c) = ss2posEnd pp + op' = if r == 0 + then MovedAnchor (ss2delta (r,c+1) la) + else MovedAnchor (ss2delta (r,c) la) + op = if t == AnnEofComment && op' == MovedAnchor (DP 0 0) + then MovedAnchor (DP 1 0) + else op' + +addCommentOrigDeltas :: ApiAnnComments -> ApiAnnComments +addCommentOrigDeltas (AnnComments cs) = AnnComments (commentOrigDeltas cs) +addCommentOrigDeltas (AnnCommentsBalanced pcs fcs) + = AnnCommentsBalanced (commentOrigDeltas pcs) (commentOrigDeltas fcs) + +addCommentOrigDeltasAnn :: (ApiAnn' a) -> (ApiAnn' a) +addCommentOrigDeltasAnn ApiAnnNotUsed = ApiAnnNotUsed +addCommentOrigDeltasAnn (ApiAnn e a cs) = ApiAnn e a (addCommentOrigDeltas cs) + +-- TODO: this is replicating functionality in ExactPrint. Sort out the +-- import loop` +anchorFromLocatedA :: LocatedA a -> RealSrcSpan +anchorFromLocatedA (L (SrcSpanAnn an loc) _) + = case an of + ApiAnnNotUsed -> realSrcSpan loc + (ApiAnn anc _ _) -> anchor anc + +-- --------------------------------------------------------------------- + +balanceSameLineComments :: (Monad m) + => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) +balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do + logTr $ "balanceSameLineComments: (la)=" ++ showGhc (ss2range $ locA la) + logTr $ "balanceSameLineComments: [logInfo]=" ++ showAst logInfo + return (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) + where + simpleBreak n (r,_) = r > n + (la',grhss', logInfo) = case reverse grhss of + [] -> (la,grhss,[]) + (L lg g@(GRHS ApiAnnNotUsed _gs _rhs):grs) -> (la,reverse $ (L lg g):grs,[]) + (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))]) + where + (SrcSpanAnn an1 _loc1) = la + anc1 = addCommentOrigDeltas $ apiAnnComments an1 + (ApiAnn anc an _) = ga :: ApiAnn' GrhsAnn + (csp,csf) = case anc1 of + AnnComments cs -> ([],cs) + AnnCommentsBalanced p f -> (p,f) + (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchor anc) csf) + move = map snd move' + stay = map snd stay' + cs1 = AnnCommentsBalanced csp stay + + gac = addCommentOrigDeltas $ apiAnnComments ga + gfc = getFollowingComments gac + gac' = setFollowingComments gac (sort $ gfc ++ move) + ga' = (ApiAnn anc an gac') + + an1' = setCommentsSrcAnn la cs1 + la'' = an1' + +-- --------------------------------------------------------------------- + + +-- |After moving an AST element, make sure any comments that may belong +-- with the following element in fact do. Of necessity this is a heuristic +-- process, to be tuned later. Possibly a variant should be provided with a +-- passed-in decision function. +balanceTrailingComments :: (Monad m) => (Data a,Data b) => Located a -> Located b + -> TransformT m [(Comment, DeltaPos)] +balanceTrailingComments first second = do + let + k1 = mkAnnKey first + k2 = mkAnnKey second + moveComments p ans = (ans',move) + where + an1 = gfromJust "balanceTrailingComments k1" $ Map.lookup k1 ans + an2 = gfromJust "balanceTrailingComments k2" $ Map.lookup k2 ans + cs1f = annFollowingComments an1 + (move,stay) = break p cs1f + an1' = an1 { annFollowingComments = stay } + ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans + + simpleBreak (_,DP r _c) = r > 0 + + ans <- getAnnsT + let (ans',mov) = moveComments simpleBreak ans + putAnnsT ans' + return mov + +-- --------------------------------------------------------------------- + +-- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for +-- |Move any 'annFollowingComments' values from the 'Annotation' associated to +-- the first parameter to that of the second. +moveTrailingComments :: (Data a,Data b) + => Located a -> Located b -> Transform () +moveTrailingComments first second = do + let + k1 = mkAnnKey first + k2 = mkAnnKey second + moveComments ans = ans' + where + an1 = gfromJust "moveTrailingComments k1" $ Map.lookup k1 ans + an2 = gfromJust "moveTrailingComments k2" $ Map.lookup k2 ans + cs1f = annFollowingComments an1 + cs2f = annFollowingComments an2 + an1' = an1 { annFollowingComments = [] } + an2' = an2 { annFollowingComments = cs1f ++ cs2f } + ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans + + modifyAnnsT moveComments + +-- --------------------------------------------------------------------- + +anchorEof :: ParsedSource -> ParsedSource +anchorEof (L l m@(HsModule an _lo _mn _exps _imps _decls _ _)) = L l (m { hsmodAnn = an' }) + where + an' = addCommentOrigDeltasAnn an + +-- --------------------------------------------------------------------- + +-- | Take an anchor and a preceding location, and generate an +-- equivalent one with a 'MovedAnchor' delta. +deltaAnchor :: Anchor -> RealSrcSpan -> Anchor +deltaAnchor (Anchor anc _) ss = Anchor anc (MovedAnchor dp) + where + dp = ss2delta (ss2pos anc) ss + +-- --------------------------------------------------------------------- + +-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the +-- given @DeltaPos@. +noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (ApiAnn' ann) +noAnnSrcSpanDP l dp + = SrcSpanAnn (ApiAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty noCom) l + +noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (ApiAnn' ann) +noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (DP 0 0) + +noAnnSrcSpanDP1 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (ApiAnn' ann) +noAnnSrcSpanDP1 l = noAnnSrcSpanDP l (DP 0 1) + +noAnnSrcSpanDPn :: (Monoid ann) => SrcSpan -> Int -> SrcSpanAnn' (ApiAnn' ann) +noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (DP 0 s) + +d0 :: AnnAnchor +d0 = AD $ DP 0 0 + +d1 :: AnnAnchor +d1 = AD $ DP 0 1 + +dn :: Int -> AnnAnchor +dn n = AD $ DP 0 n + +m0 :: AnchorOperation +m0 = MovedAnchor $ DP 0 0 + +m1 :: AnchorOperation +m1 = MovedAnchor $ DP 0 1 + +mn :: Int -> AnchorOperation +mn n = MovedAnchor $ DP 0 n + +addComma :: SrcSpanAnnA -> SrcSpanAnnA +addComma (SrcSpanAnn ApiAnnNotUsed l) + = (SrcSpanAnn (ApiAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) noCom) l) +addComma (SrcSpanAnn (ApiAnn anc (AnnListItem as) cs) l) + = (SrcSpanAnn (ApiAnn anc (AnnListItem (AddCommaAnn d0:as)) cs) l) + +-- --------------------------------------------------------------------- + +-- | Insert a declaration into an AST element having sub-declarations +-- (@HasDecls@) according to the given location function. +insertAt :: (HasDecls ast) + => (LHsDecl GhcPs + -> [LHsDecl GhcPs] + -> [LHsDecl GhcPs]) + -> ast + -> LHsDecl GhcPs + -> Transform ast +insertAt f t decl = do + oldDecls <- hsDecls t + replaceDecls t (f decl oldDecls) + +-- |Insert a declaration at the beginning or end of the subdecls of the given +-- AST item +insertAtStart, insertAtEnd :: (HasDecls ast) + => ast + -> LHsDecl GhcPs + -> Transform ast + +insertAtStart = insertAt (:) +insertAtEnd = insertAt (\x xs -> xs ++ [x]) + +-- |Insert a declaration at a specific location in the subdecls of the given +-- AST item +insertAfter, insertBefore :: (HasDecls (LocatedA ast)) + => LocatedA old + -> LocatedA ast + -> LHsDecl GhcPs + -> Transform (LocatedA ast) +insertAfter (getLocA -> k) = insertAt findAfter + where + findAfter x xs = + case span (\(L l _) -> locA l /= k) xs of + ([],[]) -> [x] + (fs,[]) -> fs++[x] + (fs, b:bs) -> fs ++ (b : x : bs) + -- let (fs, b:bs) = span (\(L l _) -> locA l /= k) xs + -- in fs ++ (b : x : bs) +insertBefore (getLocA -> k) = insertAt findBefore + where + findBefore x xs = + let (fs, bs) = span (\(L l _) -> locA l /= k) xs + in fs ++ (x : bs) + +-- ===================================================================== +-- start of HasDecls instances +-- ===================================================================== + +-- |Provide a means to get and process the immediate child declartions of a +-- given AST element. +class (Data t) => HasDecls t where +-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent + + -- | Return the 'HsDecl's that are directly enclosed in the + -- given syntax phrase. They are always returned in the wrapped 'HsDecl' + -- form, even if orginating in local decls. This is safe, as annotations + -- never attach to the wrapper, only to the wrapped item. + hsDecls :: (Monad m) => t -> TransformT m [LHsDecl GhcPs] + + -- | Replace the directly enclosed decl list by the given + -- decl list. Runs in the 'Transform' monad to be able to update list order + -- annotations, and rebalance comments and other layout changes as needed. + -- + -- For example, a call on replaceDecls for a wrapped 'FunBind' having no + -- where clause will convert + -- + -- @ + -- -- |This is a function + -- foo = x -- comment1 + -- @ + -- in to + -- + -- @ + -- -- |This is a function + -- foo = x -- comment1 + -- where + -- nn = 2 + -- @ + replaceDecls :: (Monad m) => t -> [LHsDecl GhcPs] -> TransformT m t + +-- --------------------------------------------------------------------- + +instance HasDecls ParsedSource where + hsDecls (L _ (HsModule _ _lo _mn _exps _imps decls _ _)) = return decls + replaceDecls (L l (HsModule a lo mname exps imps _decls deps haddocks)) decls + = do + logTr "replaceDecls LHsModule" + -- modifyAnnsT (captureOrder m decls) + return (L l (HsModule a lo mname exps imps decls deps haddocks)) + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where + hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsValBinds lb + + replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) [] + = do + logTr "replaceDecls LMatch empty decls" + binds'' <- replaceDeclsValbinds WithoutWhere binds [] + return (L l (Match xm c p (GRHSs xr rhs binds''))) + + replaceDecls m@(L l (Match xm c p (GRHSs xr rhs binds))) newBinds + = do + logTr "replaceDecls LMatch nonempty decls" + -- Need to throw in a fresh where clause if the binds were empty, + -- in the annotations. + (l', rhs') <- case binds of + EmptyLocalBinds{} -> do + logTr $ "replaceDecls LMatch empty binds" + modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4) + + -- only move the comment if the original where clause was empty. + -- toMove <- balanceTrailingComments m m + -- insertCommentBefore (mkAnnKey m) toMove (matchApiAnn AnnWhere) + -- TODO: move trailing comments on the same line to before the binds + logDataWithAnnsTr "Match.replaceDecls:balancing comments:m" m + L l' m' <- balanceSameLineComments m + logDataWithAnnsTr "Match.replaceDecls:(m1')" (L l' m') + return (l', grhssGRHSs $ m_grhss m') + _ -> return (l, rhs) + binds'' <- replaceDeclsValbinds WithWhere binds newBinds + logDataWithAnnsTr "Match.replaceDecls:binds'" binds'' + return (L l' (Match xm c p (GRHSs xr rhs' binds''))) + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (HsExpr GhcPs)) where + hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsValBinds decls + hsDecls _ = return [] + + replaceDecls (L ll (HsLet x binds ex)) newDecls + = do + logTr "replaceDecls HsLet" + let lastAnc = realSrcSpan $ spanHsLocaLBinds binds + -- TODO: may be an intervening comment, take account for lastAnc + let (x', ex',newDecls') = case x of + ApiAnnNotUsed -> (x, ex, newDecls) + (ApiAnn a (AnnsLet l i) cs) -> + let + off = case l of + (AR r) -> LayoutStartCol $ snd $ ss2pos r + (AD (DP 0 _)) -> LayoutStartCol 0 + (AD (DP _ c)) -> LayoutStartCol c + ex'' = setEntryDPFromAnchor off i ex + newDecls'' = case newDecls of + [] -> newDecls + (d:ds) -> setEntryDPDecl d (DP 0 0) : ds + in ( ApiAnn a (AnnsLet l (addAnnAnchorDelta off lastAnc i)) cs + , ex'' + , newDecls'') + binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' + return (L ll (HsLet x' binds' ex')) + + -- TODO: does this make sense? Especially as no hsDecls for HsPar + replaceDecls (L l (HsPar x e)) newDecls + = do + logTr "replaceDecls HsPar" + e' <- replaceDecls e newDecls + return (L l (HsPar x e')) + replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old + +-- --------------------------------------------------------------------- + +-- | Extract the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is +-- idempotent. +hsDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs] +hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d) +hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x + +-- | Extract the immediate declarations for a 'PatBind'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is +-- idempotent. +hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] +hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb) _)) = hsDeclsValBinds lb +hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x + +-- ------------------------------------- + +-- | Replace the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is +-- idempotent. +replaceDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> [LHsDecl GhcPs] + -> TransformT m (LHsDecl GhcPs) +replaceDeclsPatBindD (L l (ValD x d)) newDecls = do + (L _ d') <- replaceDeclsPatBind (L l d) newDecls + return (L l (ValD x d')) +replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x + +-- | Replace the immediate declarations for a 'PatBind'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is +-- idempotent. +replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs] + -> TransformT m (LHsBind GhcPs) +replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls + = do + logTr "replaceDecls PatBind" + -- Need to throw in a fresh where clause if the binds were empty, + -- in the annotations. + case binds of + EmptyLocalBinds{} -> do + let + addWhere _mkds = + error "TBD" + modifyAnnsT addWhere + modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4) + + _ -> return () + + -- modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls) + binds'' <- replaceDeclsValbinds WithWhere binds newDecls + -- let binds' = L (getLoc binds) binds'' + return (L l (PatBind x a (GRHSs xr rhss binds'') b)) +replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where + hsDecls (L _ (LetStmt _ lb)) = hsDeclsValBinds lb + hsDecls (L _ (LastStmt _ e _ _)) = hsDecls e + hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e + hsDecls (L _ (BodyStmt _ e _ _)) = hsDecls e + hsDecls _ = return [] + + replaceDecls (L l (LetStmt x lb)) newDecls + = do + -- modifyAnnsT (captureOrder s newDecls) + lb'' <- replaceDeclsValbinds WithWhere lb newDecls + -- let lb' = L (getLoc lb) lb'' + return (L l (LetStmt x lb'')) + replaceDecls (L l (LastStmt x e d se)) newDecls + = do + e' <- replaceDecls e newDecls + return (L l (LastStmt x e' d se)) + replaceDecls (L l (BindStmt x pat e)) newDecls + = do + e' <- replaceDecls e newDecls + return (L l (BindStmt x pat e')) + + replaceDecls (L l (BodyStmt x e a b)) newDecls + = do + e' <- replaceDecls e newDecls + return (L l (BodyStmt x e' a b)) + replaceDecls x _newDecls = return x + +-- ===================================================================== +-- end of HasDecls instances +-- ===================================================================== + +-- --------------------------------------------------------------------- + +-- |Do a transformation on an AST fragment by providing a function to process +-- the general case and one specific for a 'LHsBind'. This is required +-- because a 'FunBind' may have multiple 'Match' items, so we cannot +-- gurantee that 'replaceDecls' after 'hsDecls' is idempotent. +hasDeclsSybTransform :: (Data t2,Monad m) + => (forall t. HasDecls t => t -> m t) + -- ^Worker function for the general case + -> (LHsBind GhcPs -> m (LHsBind GhcPs)) + -- ^Worker function for FunBind/PatBind + -> t2 -- ^Item to be updated + -> m t2 +hasDeclsSybTransform workerHasDecls workerBind t = trf t + where + trf = mkM parsedSource + `extM` lmatch + `extM` lexpr + `extM` lstmt + `extM` lhsbind + `extM` lvald + + parsedSource (p::ParsedSource) = workerHasDecls p + + lmatch (lm::LMatch GhcPs (LHsExpr GhcPs)) + = workerHasDecls lm + + lexpr (le::LHsExpr GhcPs) + = workerHasDecls le + + lstmt (d::LStmt GhcPs (LHsExpr GhcPs)) + = workerHasDecls d + + lhsbind (b@(L _ FunBind{}):: LHsBind GhcPs) + = workerBind b + lhsbind b@(L _ PatBind{}) + = workerBind b + lhsbind x = return x + + lvald (L l (ValD x d)) = do + (L _ d') <- lhsbind (L l d) + return (L l (ValD x d')) + lvald x = return x + +-- --------------------------------------------------------------------- + +-- |A 'FunBind' wraps up one or more 'Match' items. 'hsDecls' cannot +-- return anything for these as there is not meaningful 'replaceDecls' for it. +-- This function provides a version of 'hsDecls' that returns the 'FunBind' +-- decls too, where they are needed for analysis only. +hsDeclsGeneric :: (Data t,Monad m) => t -> TransformT m [LHsDecl GhcPs] +hsDeclsGeneric t = q t + where + q = return [] + `mkQ` parsedSource + `extQ` lmatch + `extQ` lexpr + `extQ` lstmt + `extQ` lhsbind + `extQ` lhsbindd + `extQ` llocalbinds + `extQ` localbinds + + parsedSource (p::ParsedSource) = hsDecls p + + lmatch (lm::LMatch GhcPs (LHsExpr GhcPs)) = hsDecls lm + + lexpr (le::LHsExpr GhcPs) = hsDecls le + + lstmt (d::LStmt GhcPs (LHsExpr GhcPs)) = hsDecls d + + -- --------------------------------- + + lhsbind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] + lhsbind (L _ (FunBind _ _ (MG _ (L _ matches) _) _)) = do + dss <- mapM hsDecls matches + return (concat dss) + lhsbind p@(L _ (PatBind{})) = do + hsDeclsPatBind p + lhsbind _ = return [] + + -- --------------------------------- + + lhsbindd (L l (ValD _ d)) = lhsbind (L l d) + lhsbindd _ = return [] + + -- --------------------------------- + + llocalbinds :: (Monad m) => Located (HsLocalBinds GhcPs) -> TransformT m [LHsDecl GhcPs] + llocalbinds (L _ ds) = localbinds ds + + -- --------------------------------- + + localbinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs] + localbinds d = hsDeclsValBinds d + +-- --------------------------------------------------------------------- + +-- |Look up the annotated order and sort the decls accordingly +-- TODO:AZ: this should be pure +orderedDecls :: (Monad m) + => AnnSortKey -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] +orderedDecls sortKey decls = do + case sortKey of + NoAnnSortKey -> do + -- return decls + return $ sortBy (\a b -> compare (realSrcSpan $ getLocA a) (realSrcSpan $ getLocA b)) decls + AnnSortKey keys -> do + let ds = map (\s -> (rs $ getLocA s,s)) decls + ordered = map snd $ orderByKey ds keys + return ordered + +-- --------------------------------------------------------------------- + +hsDeclsValBinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs] +hsDeclsValBinds lb = case lb of + HsValBinds _ (ValBinds sortKey bs sigs) -> do + let + bds = map wrapDecl (bagToList bs) + sds = map wrapSig sigs + orderedDecls sortKey (bds ++ sds) + HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" + HsIPBinds {} -> return [] + EmptyLocalBinds {} -> return [] + +data WithWhere = WithWhere + | WithoutWhere + deriving (Eq,Show) + +-- | Utility function for returning decls to 'HsLocalBinds'. Use with +-- care, as this does not manage the declaration order, the +-- ordering should be done by the calling function from the 'HsLocalBinds' +-- context in the AST. +replaceDeclsValbinds :: (Monad m) + => WithWhere + -> HsLocalBinds GhcPs -> [LHsDecl GhcPs] + -> TransformT m (HsLocalBinds GhcPs) +replaceDeclsValbinds _ _ [] = do + return (EmptyLocalBinds NoExtField) +replaceDeclsValbinds w b@(HsValBinds a _) new + = do + logTr "replaceDeclsValbinds" + let oldSpan = spanHsLocaLBinds b + an <- oldWhereAnnotation a w (realSrcSpan oldSpan) + let decs = listToBag $ concatMap decl2Bind new + let sigs = concatMap decl2Sig new + let sortKey = captureOrder new + return (HsValBinds an (ValBinds sortKey decs sigs)) +replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" +replaceDeclsValbinds w (EmptyLocalBinds _) new + = do + logTr "replaceDecls HsLocalBinds" + an <- newWhereAnnotation w + let newBinds = concatMap decl2Bind new + newSigs = concatMap decl2Sig new + let decs = listToBag $ newBinds + let sigs = newSigs + let sortKey = captureOrder new + return (HsValBinds an (ValBinds sortKey decs sigs)) + +oldWhereAnnotation :: (Monad m) + => ApiAnn' AnnList -> WithWhere -> RealSrcSpan -> TransformT m (ApiAnn' AnnList) +oldWhereAnnotation ApiAnnNotUsed ww _oldSpan = do + newSpan <- uniqueSrcSpanT + let w = case ww of + WithWhere -> [AddApiAnn AnnWhere (AD (DP 0 0))] + WithoutWhere -> [] + let anc2' = Anchor (rs newSpan) (MovedAnchor (DP 0 1)) + (anc, anc2) <- do + newSpan' <- uniqueSrcSpanT + return ( Anchor (rs newSpan') (MovedAnchor (DP 1 2)) + , anc2') + let an = ApiAnn anc + (AnnList (Just anc2) Nothing Nothing w []) + noCom + return an +oldWhereAnnotation (ApiAnn anc an cs) ww _oldSpan = do + -- TODO: when we set DP (0,0) for the HsValBinds ApiAnnAnchor, change the AnnList anchor to have the correct DP too + let (AnnList ancl o c _r t) = an + let w = case ww of + WithWhere -> [AddApiAnn AnnWhere (AD (DP 0 0))] + WithoutWhere -> [] + (anc', ancl') <- do + case ww of + WithWhere -> return (anc, ancl) + WithoutWhere -> return (anc, ancl) + let an' = ApiAnn anc' + (AnnList ancl' o c w t) + cs + return an' + +newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (ApiAnn' AnnList) +newWhereAnnotation ww = do + newSpan <- uniqueSrcSpanT + let anc = Anchor (rs newSpan) (MovedAnchor (DP 1 2)) + let anc2 = Anchor (rs newSpan) (MovedAnchor (DP 1 4)) + let w = case ww of + WithWhere -> [AddApiAnn AnnWhere (AD (DP 0 0))] + WithoutWhere -> [] + let an = ApiAnn anc + (AnnList (Just anc2) Nothing Nothing w []) + noCom + return an + +-- --------------------------------------------------------------------- + +type Decl = LHsDecl GhcPs +type PMatch = LMatch GhcPs (LHsExpr GhcPs) + +-- |Modify a 'LHsBind' wrapped in a 'ValD'. For a 'PatBind' the +-- declarations are extracted and returned after modification. For a +-- 'FunBind' the supplied 'SrcSpan' is used to identify the specific +-- 'Match' to be transformed, for when there are multiple of them. +modifyValD :: forall m t. (HasTransform m) + => SrcSpan + -> Decl + -> (PMatch -> [Decl] -> m ([Decl], Maybe t)) + -> m (Decl,Maybe t) +modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f = + if (locA ss) == p + then do + ds <- liftT $ hsDeclsPatBindD pb + (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds + pb' <- liftT $ replaceDeclsPatBindD pb ds' + return (pb',r) + else return (pb,Nothing) +modifyValD p ast f = do + (ast',r) <- runStateT (everywhereM (mkM doModLocal) ast) Nothing + return (ast',r) + where + doModLocal :: PMatch -> StateT (Maybe t) m PMatch + doModLocal (match@(L ss _) :: PMatch) = do + if (locA ss) == p + then do + ds <- lift $ liftT $ hsDecls match + (ds',r) <- lift $ f match ds + put r + match' <- lift $ liftT $ replaceDecls match ds' + return match' + else return match + +-- --------------------------------------------------------------------- + +-- |Used to integrate a @Transform@ into other Monad stacks +class (Monad m) => (HasTransform m) where + liftT :: Transform a -> m a + +instance Monad m => HasTransform (TransformT m) where + liftT = hoistTransform (return . runIdentity) + +-- --------------------------------------------------------------------- + +-- | Apply a transformation to the decls contained in @t@ +modifyDeclsT :: (HasDecls t,HasTransform m) + => ([LHsDecl GhcPs] -> m [LHsDecl GhcPs]) + -> t -> m t +modifyDeclsT action t = do + decls <- liftT $ hsDecls t + decls' <- action decls + liftT $ replaceDecls t decls' + +-- --------------------------------------------------------------------- diff --git a/utils/check-exact/Types.hs b/utils/check-exact/Types.hs new file mode 100644 index 0000000000..46ce9b4291 --- /dev/null +++ b/utils/check-exact/Types.hs @@ -0,0 +1,331 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Types + where + +import GHC hiding (AnnComment) +-- import GHC.Hs.Extension +-- import GHC.Parser.Lexer (AddApiAnn(..)) +-- import GHC.Types.Basic hiding (EP) +-- import GHC.Types.Name.Reader +-- import GHC.Types.SrcLoc +import GHC.Utils.Outputable hiding ( (<>) ) +-- import GHC.Driver.Session +import GHC.Driver.Ppr +-- import Control.Monad.Identity +-- import Control.Monad.RWS +import Data.Data (Data, toConstr,cast) +-- import Data.Foldable +-- import Data.List (sortBy, elemIndex) +-- import Data.Maybe (fromMaybe) +-- import Data.Ord (comparing) + +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- import qualified GHC +-- import Lookup + +-- --------------------------------------------------------------------- + +-- --------------------------------------------------------------------- +-- | This structure holds a complete set of annotations for an AST +type Anns = Map.Map AnnKey Annotation + +emptyAnns :: Anns +emptyAnns = Map.empty + +-- | For every @Located a@, use the @SrcSpan@ and constructor name of +-- a as the key, to store the standard annotation. +-- These are used to maintain context in the AP and EP monads +data AnnKey = AnnKey RealSrcSpan AnnConName + deriving (Eq, Data, Ord) +-- deriving instance Ord SrcSpan + +-- More compact Show instance +instance Show AnnKey where + show (AnnKey ss cn) = "AnnKey " ++ showPprUnsafe ss ++ " " ++ show cn + +mkAnnKeyPrim :: (Data a) => Located a -> AnnKey +mkAnnKeyPrim (L l a) = AnnKey (realSrcSpan l) (annGetConstr a) + +mkAnnKeyPrimA :: (Data a) => LocatedA a -> AnnKey +mkAnnKeyPrimA (L l a) = AnnKey (realSrcSpan $ locA l) (annGetConstr a) + +-- Holds the name of a constructor +data AnnConName = CN { unConName :: String } + deriving (Eq, Ord, Data) + +-- More compact show instance +instance Show AnnConName where + show (CN s) = "CN " ++ show s + +annGetConstr :: (Data a) => a -> AnnConName +annGetConstr a = CN (show $ toConstr a) + +-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. +mkAnnKey :: (Data a) => Located a -> AnnKey +mkAnnKey ld = + case cast ld :: Maybe (LHsDecl GhcPs) of + Just d -> declFun mkAnnKeyPrimA d + Nothing -> mkAnnKeyPrim ld + + +type Pos = (Int,Int) + +deltaRow, deltaColumn :: DeltaPos -> Int +deltaRow (DP r _) = r +deltaColumn (DP _ c) = c + +-- --------------------------------------------------------------------- + +annNone :: Annotation +annNone = Ann (DP 0 0) [] [] [] Nothing Nothing + +data Annotation = Ann + { + -- The first three fields relate to interfacing up into the AST + annEntryDelta :: !DeltaPos + -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior + -- output was, including all annPriorComments (field below). + , annPriorComments :: ![(Comment, DeltaPos)] + -- ^ Comments coming after the last non-comment output of the preceding + -- element but before the SrcSpan being annotated by this Annotation. If + -- these are changed then annEntryDelta (field above) must also change to + -- match. + , annFollowingComments :: ![(Comment, DeltaPos)] + -- ^ Comments coming after the last output for the element subject to this + -- Annotation. These will only be added by AST transformations, and care + -- must be taken not to disturb layout of following elements. + + -- The next three fields relate to interacing down into the AST + , annsDP :: ![(KeywordId, DeltaPos)] + -- ^ Annotations associated with this element. + , annSortKey :: !(Maybe [RealSrcSpan]) + -- ^ Captures the sort order of sub elements. This is needed when the + -- sub-elements have been split (as in a HsLocalBind which holds separate + -- binds and sigs) or for infix patterns where the order has been + -- re-arranged. It is captured explicitly so that after the Delta phase a + -- SrcSpan is used purely as an index into the annotations, allowing + -- transformations of the AST including the introduction of new Located + -- items or re-arranging existing ones. + , annCapturedSpan :: !(Maybe AnnKey) + -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of + -- elements which we must remember for the Print phase. e.g. the statements + -- in a HsLet or HsDo. These must be managed as a group because they all + -- need eo be vertically aligned for the Haskell layout rules, and this + -- guarantees this property in the presence of AST edits. + + } deriving (Eq) + +-- --------------------------------------------------------------------- + +declFun :: (forall a . Data a => LocatedA a -> b) -> LHsDecl GhcPs -> b +declFun f (L l de) = + case de of + TyClD _ d -> f (L l d) + InstD _ d -> f (L l d) + DerivD _ d -> f (L l d) + ValD _ d -> f (L l d) + SigD _ d -> f (L l d) + KindSigD _ d -> f (L l d) + DefD _ d -> f (L l d) + ForD _ d -> f (L l d) + WarningD _ d -> f (L l d) + AnnD _ d -> f (L l d) + RuleD _ d -> f (L l d) + SpliceD _ d -> f (L l d) + DocD _ d -> f (L l d) + RoleAnnotD _ d -> f (L l d) + +-- --------------------------------------------------------------------- + +data ACS' a = ACS + { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should + -- propagate down the AST. Removed when it hits zero + } deriving (Show) + +instance Semigroup (ACS' AstContext) where + ACS a <> ACS b = ACS (Map.unionWith max a b) + -- For Data.Map, mappend == union, which is a left-biased replace + -- for key collisions + +instance Monoid (ACS' AstContext) where + mempty = ACS mempty + +type AstContextSet = ACS' AstContext +-- data AstContextSet = ACS +-- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should +-- -- propagate down the AST. Removed when it +-- -- hits zero +-- } deriving (Show) + +defaultACS :: AstContextSet +defaultACS = ACS Map.empty + +-- instance Outputable AstContextSet where +instance (Show a) => Outputable (ACS' a) where + ppr x = text $ show x + +data AstContext = -- LambdaExpr + CaseAlt + | NoPrecedingSpace + | HasHiding + | AdvanceLine + | NoAdvanceLine + | Intercalate -- This item may have a list separator following + | InIE -- possible 'type' or 'pattern' + | PrefixOp + | PrefixOpDollar + | InfixOp -- RdrName may be used as an infix operator + | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently + | ListItem -- Identifies subsequent elements of a list in layout + | TopLevelDecl -- top level declaration + | NoDarrow + | AddVbar + | Deriving + | Parens -- TODO: Not currently used? + | ExplicitNeverActive + | InGadt + | InRecCon + | InClassDecl + | InSpliceDecl + | LeftMost -- Is this the leftmost operator in a chain of OpApps? + | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt + -- TODO:AZ: do we actually need this? + + -- Next four used to identify current list context + | CtxOnly + | CtxFirst + | CtxMiddle + | CtxLast + | CtxPos Int -- 0 for first, increasing for subsequent + + -- Next are used in tellContext to push context up the tree + | FollowingLine + deriving (Eq, Ord, Show) + + +data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) } + deriving (Eq,Show) + +-- --------------------------------------------------------------------- + +data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) + +-- -- --------------------------------------------------------------------- +-- -- | This structure holds a complete set of annotations for an AST +-- type Anns = Map.Map AnnKey Annotation + +-- emptyAnns :: Anns +-- emptyAnns = Map.empty + +-- -- | For every @Located a@, use the @SrcSpan@ and constructor name of +-- -- a as the key, to store the standard annotation. +-- -- These are used to maintain context in the AP and EP monads +-- data AnnKey = AnnKey SrcSpan AnnConName +-- deriving (Eq, Data, Ord) +-- deriving instance Ord SrcSpan + +-- -- More compact Show instance +-- instance Show AnnKey where +-- show (AnnKey ss cn) = "AnnKey " ++ showPprUnsafe ss ++ " " ++ show cn + +-- mkAnnKeyPrim :: (Data a) => Located a -> AnnKey +-- mkAnnKeyPrim (L l a) = AnnKey l (annGetConstr a) + +-- mkAnnKeyPrimA :: (Data a) => LocatedA a -> AnnKey +-- mkAnnKeyPrimA (L l a) = AnnKey (locA l) (annGetConstr a) + +-- -- Holds the name of a constructor +-- data AnnConName = CN { unConName :: String } +-- deriving (Eq, Ord, Data) + +-- -- More compact show instance +-- instance Show AnnConName where +-- show (CN s) = "CN " ++ show s + +-- annGetConstr :: (Data a) => a -> AnnConName +-- annGetConstr a = CN (show $ toConstr a) + +-- -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. +-- mkAnnKey :: (Data a) => Located a -> AnnKey +-- mkAnnKey ld = +-- case cast ld :: Maybe (LHsDecl GhcPs) of +-- Just d -> declFun mkAnnKeyPrimA d +-- Nothing -> mkAnnKeyPrim ld + + +-- type Pos = (Int,Int) + +-- -- | A relative positions, row then column +-- newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Data) + +-- deltaRow, deltaColumn :: DeltaPos -> Int +-- deltaRow (DP (r, _)) = r +-- deltaColumn (DP (_, c)) = c + +-- --------------------------------------------------------------------- + +-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted +-- from an @AnnKeywordId@ because the annotation must be interleaved into the +-- stream and does not have a well-defined position +data Comment = Comment + { + commentContents :: !String -- ^ The contents of the comment including separators + + -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is + -- the thing we use to decide where in the output stream the comment should + -- go. + , commentAnchor :: !Anchor + , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. + } + deriving (Eq) + +instance Show Comment where + show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showPprUnsafe ss ++ " " ++ show o ++ ")" + +instance Ord Comment where + compare (Comment _ ss1 _) (Comment _ ss2 _) = compare (anchor ss1) (anchor ss2) + +instance Outputable Comment where + ppr x = text (show x) + +-- | The different syntactic elements which are not represented in the +-- AST. +data KeywordId = G AnnKeywordId -- ^ A normal keyword + | AnnSemiSep -- ^ A separating comma + | AnnTypeApp -- ^ Visible type application annotation + | AnnComment Comment + | AnnString String -- ^ Used to pass information from + -- Delta to Print when we have to work + -- out details from the original + -- SrcSpan. + deriving (Eq) + +instance Show KeywordId where + show (G gc) = "(G " ++ show gc ++ ")" + show AnnSemiSep = "AnnSemiSep" + show AnnTypeApp = "AnnTypeApp" + show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")" + show (AnnString s) = "(AnnString " ++ s ++ ")" + +-- | Marks the start column of a layout block. +newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int } + deriving (Eq, Num) + +instance Show LayoutStartCol where + show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")" +-- --------------------------------------------------------------------- + +-- Duplicated here so it can be used in show instances +showGhc :: (Outputable a) => a -> String +showGhc = showPprUnsafe diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs new file mode 100644 index 0000000000..23f166514f --- /dev/null +++ b/utils/check-exact/Utils.hs @@ -0,0 +1,596 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Utils + -- ( + -- -- * Manipulating Positons + -- ss2pos + -- , ss2posEnd + -- , undelta + -- , isPointSrcSpan + -- , pos2delta + -- , ss2delta + -- , addDP + -- , spanLength + -- , isGoodDelta + -- ) where + where +import Control.Monad.State +-- import qualified Data.ByteString as B +-- import GHC.Generics hiding (Fixity) +import Data.Function +import Data.Ord (comparing) + +import GHC.Hs.Dump +-- import Language.Haskell.GHC.ExactPrint.Types +import Lookup + +-- import GHC.Data.Bag +-- import GHC.Driver.Session +-- import GHC.Data.FastString +import GHC hiding (AnnComment) +import qualified GHC +-- import qualified Name as GHC +-- import qualified NameSet as GHC +-- import GHC.Utils.Outputable +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Driver.Ppr +import GHC.Data.FastString +-- import GHC.Types.Var +-- import GHC.Types.Name.Occurrence + +-- import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief) +import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),pprNameSpaceBrief) + +import Control.Arrow + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Data hiding ( Fixity ) +import Data.List + +import Debug.Trace +import Types + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print +debugEnabledFlag :: Bool +-- debugEnabledFlag = True +debugEnabledFlag = False + +-- |Global switch to enable debug tracing in ghc-exactprint Pretty +debugPEnabledFlag :: Bool +debugPEnabledFlag = True +-- debugPEnabledFlag = False + +-- |Provide a version of trace that comes at the end of the line, so it can +-- easily be commented out when debugging different things. +debug :: c -> String -> c +debug c s = if debugEnabledFlag + then trace s c + else c + +-- |Provide a version of trace for the Pretty module, which can be enabled +-- separately from 'debug' and 'debugM' +debugP :: String -> c -> c +debugP s c = if debugPEnabledFlag + then trace s c + else c + +debugM :: Monad m => String -> m () +debugM s = when debugEnabledFlag $ traceM s + + +-- --------------------------------------------------------------------- + +warn :: c -> String -> c +-- warn = flip trace +warn c _ = c + +-- | A good delta has no negative values. +isGoodDelta :: DeltaPos -> Bool +isGoodDelta (DP ro co) = ro >= 0 && co >= 0 + + +-- | Create a delta from the current position to the start of the given +-- @SrcSpan@. +ss2delta :: Pos -> RealSrcSpan -> DeltaPos +ss2delta ref ss = pos2delta ref (ss2pos ss) + +-- | create a delta from the end of a current span. The +1 is because +-- the stored position ends up one past the span, this is prior to +-- that adjustment +ss2deltaEnd :: RealSrcSpan -> RealSrcSpan -> DeltaPos +ss2deltaEnd rrs ss = ss2delta ref ss + where + (r,c) = ss2posEnd rrs + ref = if r == 0 + then (r,c+1) + else (r,c) + +-- | create a delta from the start of a current span. The +1 is +-- because the stored position ends up one past the span, this is +-- prior to that adjustment +ss2deltaStart :: RealSrcSpan -> RealSrcSpan -> DeltaPos +ss2deltaStart rrs ss = ss2delta ref ss + where + (r,c) = ss2pos rrs + ref = if r == 0 + -- then (r,c+1) + then (r,c) + else (r,c) + +-- | Convert the start of the second @Pos@ to be an offset from the +-- first. The assumption is the reference starts before the second @Pos@ +pos2delta :: Pos -> Pos -> DeltaPos +pos2delta (refl,refc) (l,c) = DP lo co + where + lo = l - refl + co = if lo == 0 then c - refc + else c + +-- | Apply the delta to the current position, taking into account the +-- current column offset if advancing to a new line +undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos +undelta (l,c) (DP dl dc) (LayoutStartCol co) = (fl,fc) + where + fl = l + dl + fc = if dl == 0 then c + dc + else co + dc + +undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddApiAnn +undeltaSpan anchor kw dp = AddApiAnn kw (AR sp) + where + (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0) + len = length (keywordToString (G kw)) + sp = range2rs ((l,c),(l,c+len)) + +-- | Add together two @DeltaPos@ taking into account newlines +-- +-- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 3) +-- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5) +-- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3) +addDP :: DeltaPos -> DeltaPos -> DeltaPos +addDP (DP a b) (DP c d) = + if c >= 1 then DP (a+c) d + else DP a (b+d) + +-- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the +-- remaining delta for the second after the first has been applied. +-- invariant : if c = a `addDP` b +-- then a `stepDP` c == b +-- +-- Cases where first DP is <= than second +-- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1) +-- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0) +-- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1) +-- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4) +-- +-- Cases where first DP is > than second +-- > DP (0, 3) `addDP` DP (0, 2) == DP (0,1) -- advance one at least +-- > DP (3, 3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col +-- > DP (3, 3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least +-- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col +stepDP :: DeltaPos -> DeltaPos -> DeltaPos +stepDP (DP a b) (DP c d) + | (a,b) == (c,d) = DP a b + | a == c = if b < d then DP 0 (d - b) + else if d == 0 + then DP 1 0 + else DP c d + | a < c = DP (c - a) d + | otherwise = DP 1 d + +-- --------------------------------------------------------------------- + +adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos +adjustDeltaForOffset _ _colOffset dp@(DP 0 _) = dp -- same line +adjustDeltaForOffset d (LayoutStartCol colOffset) (DP l c) = DP l (c - colOffset - d) + +-- --------------------------------------------------------------------- + +ss2pos :: RealSrcSpan -> Pos +ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss) + +ss2posEnd :: RealSrcSpan -> Pos +ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndCol ss) + +ss2range :: SrcSpan -> (Pos,Pos) +ss2range ss = (ss2pos $ rs ss, ss2posEnd $ rs ss) + +rs2range :: RealSrcSpan -> (Pos,Pos) +rs2range ss = (ss2pos ss, ss2posEnd ss) + +rs :: SrcSpan -> RealSrcSpan +rs (RealSrcSpan s _) = s +rs _ = badRealSrcSpan + +range2rs :: (Pos,Pos) -> RealSrcSpan +range2rs (s,e) = mkRealSrcSpan (mkLoc s) (mkLoc e) + where + mkLoc (l,c) = mkRealSrcLoc (fsLit "ghc-exactprint") l c + +badRealSrcSpan :: RealSrcSpan +badRealSrcSpan = mkRealSrcSpan bad bad + where + bad = mkRealSrcLoc (fsLit "ghc-exactprint-nospan") 0 0 + +spanLength :: RealSrcSpan -> Int +spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol + +-- --------------------------------------------------------------------- +-- | Checks whether a SrcSpan has zero length. +isPointSrcSpan :: RealSrcSpan -> Bool +isPointSrcSpan ss = spanLength ss == 0 + && srcSpanStartLine ss == srcSpanEndLine ss + +-- --------------------------------------------------------------------- + +-- |Given a list of items and a list of keys, returns a list of items +-- ordered by their position in the list of keys. +orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)] +orderByKey keys order + -- AZ:TODO: if performance becomes a problem, consider a Map of the order + -- SrcSpan to an index, and do a lookup instead of elemIndex. + + -- Items not in the ordering are placed to the start + = sortBy (comparing (flip elemIndex order . fst)) keys + +-- --------------------------------------------------------------------- + +isListComp :: HsStmtContext name -> Bool +isListComp cts = case cts of + ListComp -> True + MonadComp -> True + + DoExpr {} -> False + MDoExpr {} -> False + ArrowExpr -> False + GhciStmtCtxt -> False + + PatGuard {} -> False + ParStmtCtxt {} -> False + TransStmtCtxt {} -> False + +-- --------------------------------------------------------------------- + +isGadt :: [LConDecl (GhcPass p)] -> Bool +isGadt [] = False +isGadt ((L _ (ConDeclGADT{})):_) = True +isGadt _ = False + +-- --------------------------------------------------------------------- + +-- Is a RdrName of type Exact? SYB query, so can be extended to other types too +isExactName :: (Data name) => name -> Bool +isExactName = False `mkQ` isExact + +-- --------------------------------------------------------------------- + +ghcCommentText :: LAnnotationComment -> String +ghcCommentText (L _ (GHC.AnnComment (AnnDocCommentNext s) _)) = s +ghcCommentText (L _ (GHC.AnnComment (AnnDocCommentPrev s) _)) = s +ghcCommentText (L _ (GHC.AnnComment (AnnDocCommentNamed s) _)) = s +ghcCommentText (L _ (GHC.AnnComment (AnnDocSection _ s) _)) = s +ghcCommentText (L _ (GHC.AnnComment (AnnDocOptions s) _)) = s +ghcCommentText (L _ (GHC.AnnComment (AnnLineComment s) _)) = s +ghcCommentText (L _ (GHC.AnnComment (AnnBlockComment s) _)) = s +ghcCommentText (L _ (GHC.AnnComment (AnnEofComment) _)) = "" + +tokComment :: LAnnotationComment -> Comment +tokComment t@(L lt _) = mkComment (normaliseCommentText $ ghcCommentText t) lt + +mkComment :: String -> Anchor -> Comment +mkComment c anc = Comment c anc Nothing + +-- Windows comments include \r in them from the lexer. +normaliseCommentText :: String -> String +normaliseCommentText [] = [] +normaliseCommentText ('\r':xs) = normaliseCommentText xs +normaliseCommentText (x:xs) = x:normaliseCommentText xs + +-- | Makes a comment which originates from a specific keyword. +mkKWComment :: AnnKeywordId -> AnnAnchor -> Comment +mkKWComment kw (AR ss) + = Comment (keywordToString $ G kw) (Anchor ss UnchangedAnchor) (Just kw) +mkKWComment kw (AD dp) + = Comment (keywordToString $ G kw) (Anchor placeholderRealSpan (MovedAnchor dp)) (Just kw) + +comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos) +comment2dp = first AnnComment + + +rogueComments :: ApiAnns -> [Comment] +rogueComments as = extractRogueComments as + -- where + -- go :: Comment -> (Comment, DeltaPos) + -- go c@(Comment _str loc _mo) = (c, ss2delta (1,1) loc) + +-- extractComments :: ApiAnns -> [Comment] +-- extractComments anns +-- -- cm has type :: Map RealSrcSpan [LAnnotationComment] +-- -- = map tokComment . sortRealLocated . concat $ Map.elems (apiAnnComments anns) +-- = [] + +extractRogueComments :: ApiAnns -> [Comment] +extractRogueComments anns + -- cm has type :: Map RealSrcSpan [LAnnotationComment] + = map tokComment $ sortAnchorLocated (apiAnnRogueComments anns) + +sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a] +sortAnchorLocated = sortBy (compare `on` (anchor . getLoc)) + + +getAnnotationEP :: (Data a) => Located a -> Anns -> Maybe Annotation +getAnnotationEP la as = + Map.lookup (mkAnnKey la) as + +-- | The "true entry" is the distance from the last concrete element to the +-- start of the current element. +annTrueEntryDelta :: Annotation -> DeltaPos +annTrueEntryDelta Ann{annEntryDelta, annPriorComments} = + foldr addDP (DP 0 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) + `addDP` annEntryDelta + +-- | Take an annotation and a required "true entry" and calculate an equivalent +-- one relative to the last comment in the annPriorComments. +annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos +annCommentEntryDelta Ann{annPriorComments} trueDP = dp + where + commentDP = + foldr addDP (DP 0 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) + dp = stepDP commentDP trueDP + +-- | Return the DP of the first item that generates output, either a comment or the entry DP +annLeadingCommentEntryDelta :: Annotation -> DeltaPos +annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp + where + dp = case annPriorComments of + [] -> annEntryDelta + ((_,ed):_) -> ed + +-- | Calculates the distance from the start of a string to the end of +-- a string. +dpFromString :: String -> DeltaPos +dpFromString xs = dpFromString' xs 0 0 + where + dpFromString' "" line col = DP line col + dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0 + dpFromString' (_:cs) line col = dpFromString' cs line (col + 1) + +-- --------------------------------------------------------------------- + +isSymbolRdrName :: RdrName -> Bool +isSymbolRdrName n = isSymOcc $ rdrNameOcc n + +rdrName2String :: RdrName -> String +rdrName2String r = + case isExact_maybe r of + Just n -> name2String n + Nothing -> + case r of + Unqual occ -> occNameString occ + Qual modname occ -> moduleNameString modname ++ "." + ++ occNameString occ + Orig _ occ -> occNameString occ + Exact n -> getOccString n + +name2String :: Name -> String +name2String = showPprUnsafe + +-- --------------------------------------------------------------------- + +-- | Put the provided context elements into the existing set with fresh level +-- counts +setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet +setAcs ctxt acs = setAcsWithLevel ctxt 3 acs + +-- | Put the provided context elements into the existing set with given level +-- counts +-- setAcsWithLevel :: Set.Set AstContext -> Int -> AstContextSet -> AstContextSet +-- setAcsWithLevel ctxt level (ACS a) = ACS a' +-- where +-- upd s (k,v) = Map.insert k v s +-- a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) +setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a +setAcsWithLevel ctxt level (ACS a) = ACS a' + where + upd s (k,v) = Map.insert k v s + a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) + +-- --------------------------------------------------------------------- +-- | Remove the provided context element from the existing set +-- unsetAcs :: AstContext -> AstContextSet -> AstContextSet +unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a +unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a + +-- --------------------------------------------------------------------- + +-- | Are any of the contexts currently active? +-- inAcs :: Set.Set AstContext -> AstContextSet -> Bool +inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool +inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a) + +-- | propagate the ACS down a level, dropping all values which hit zero +-- pushAcs :: AstContextSet -> AstContextSet +pushAcs :: ACS' a -> ACS' a +pushAcs (ACS a) = ACS $ Map.mapMaybe f a + where + f n + | n <= 1 = Nothing + | otherwise = Just (n - 1) + +-- |Sometimes we have to pass the context down unchanged. Bump each count up by +-- one so that it is unchanged after a @pushAcs@ call. +-- bumpAcs :: AstContextSet -> AstContextSet +bumpAcs :: ACS' a -> ACS' a +bumpAcs (ACS a) = ACS $ Map.mapMaybe f a + where + f n = Just (n + 1) + +-- --------------------------------------------------------------------- + +occAttributes :: OccName.OccName -> String +occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" + where + -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " + ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " + vo = if isVarOcc o then "Var " else "" + tv = if isTvOcc o then "Tv " else "" + tc = if isTcOcc o then "Tc " else "" + d = if isDataOcc o then "Data " else "" + ds = if isDataSymOcc o then "DataSym " else "" + s = if isSymOcc o then "Sym " else "" + v = if isValOcc o then "Val " else "" + +{- +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. +-} + + -- --------------------------------------------------------------------- + +locatedAnAnchor :: LocatedAn a t -> RealSrcSpan +locatedAnAnchor (L (SrcSpanAnn ApiAnnNotUsed l) _) = realSrcSpan l +locatedAnAnchor (L (SrcSpanAnn (ApiAnn a _ _) _) _) = anchor a + + -- --------------------------------------------------------------------- + +-- showSDoc_ :: SDoc -> String +-- showSDoc_ = showSDoc unsafeGlobalDynFlags + +-- showSDocDebug_ :: SDoc -> String +-- showSDocDebug_ = showSDocDebug unsafeGlobalDynFlags + + + -- --------------------------------------------------------------------- + +showAst :: (Data a) => a -> String +showAst ast + = showSDocUnsafe + $ showAstData NoBlankSrcSpan NoBlankApiAnnotations ast + +-- --------------------------------------------------------------------- +-- Putting these here for the time being, to avoid import loops + +ghead :: String -> [a] -> a +ghead info [] = error $ "ghead "++info++" []" +ghead _info (h:_) = h + +glast :: String -> [a] -> a +glast info [] = error $ "glast " ++ info ++ " []" +glast _info h = last h + +gtail :: String -> [a] -> [a] +gtail info [] = error $ "gtail " ++ info ++ " []" +gtail _info h = tail h + +gfromJust :: String -> Maybe a -> a +gfromJust _info (Just h) = h +gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing" + +-- --------------------------------------------------------------------- + +-- Copied from syb for the test + + +-- | Generic queries of type \"r\", +-- i.e., take any \"a\" and return an \"r\" +-- +type GenericQ r = forall a. Data a => a -> r + + +-- | Make a generic query; +-- start from a type-specific case; +-- return a constant otherwise +-- +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + +-- | Make a generic monadic transformation; +-- start from a type-specific case; +-- resort to return otherwise +-- +mkM :: ( Monad m + , Typeable a + , Typeable b + ) + => (b -> m b) + -> a + -> m a +mkM = extM return + +-- | Flexible type extension +ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a +ext0 def ext = maybe def id (gcast ext) + + +-- | Extend a generic query by a type-specific case +extQ :: ( Typeable a + , Typeable b + ) + => (a -> q) + -> (b -> q) + -> a + -> q +extQ f g a = maybe (f a) g (cast a) + +-- | Flexible type extension +ext2 :: (Data a, Typeable t) + => c a + -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) + -> c a +ext2 def ext = maybe def id (dataCast2 ext) + + +-- | Extend a generic monadic transformation by a type-specific case +extM :: ( Monad m + , Typeable a + , Typeable b + ) + => (a -> m a) -> (b -> m b) -> a -> m a +extM def ext = unM ((M def) `ext0` (M ext)) + +-- | Type extension of monadic transformations for type constructors +ext2M :: (Monad m, Data d, Typeable t) + => (forall e. Data e => e -> m e) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2)) + -> d -> m d +ext2M def ext = unM ((M def) `ext2` (M ext)) + +-- | The type constructor for transformations +newtype M m x = M { unM :: x -> m x } + +-- | Generic monadic transformations, +-- i.e., take an \"a\" and compute an \"a\" +-- +type GenericM m = forall a. Data a => a -> m a + +-- | Monadic variation on everywhere +everywhereM :: forall m. Monad m => GenericM m -> GenericM m + +-- Bottom-up order is also reflected in order of do-actions +everywhereM f = go + where + go :: GenericM m + go x = do + x' <- gmapM go x + f x' diff --git a/utils/check-exact/cases/AddDecl1.expected.hs b/utils/check-exact/cases/AddDecl1.expected.hs new file mode 100644 index 0000000000..88ef0fdd7d --- /dev/null +++ b/utils/check-exact/cases/AddDecl1.expected.hs @@ -0,0 +1,13 @@ +module AddDecl where + +nn = n2 + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +-- | Do bar +bar x y = {- baz -} foo (x+y) x + +-- end of file diff --git a/utils/check-exact/cases/AddDecl1.hs b/utils/check-exact/cases/AddDecl1.hs new file mode 100644 index 0000000000..45c0cb3864 --- /dev/null +++ b/utils/check-exact/cases/AddDecl1.hs @@ -0,0 +1,11 @@ +module AddDecl where + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +-- | Do bar +bar x y = {- baz -} foo (x+y) x + +-- end of file diff --git a/utils/check-exact/cases/AddDecl2.expected.hs b/utils/check-exact/cases/AddDecl2.expected.hs new file mode 100644 index 0000000000..2bbbcf5b37 --- /dev/null +++ b/utils/check-exact/cases/AddDecl2.expected.hs @@ -0,0 +1,13 @@ +module AddDecl where + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +-- | Do bar +bar x y = {- baz -} foo (x+y) x + +nn = n2 + +-- end of file diff --git a/utils/check-exact/cases/AddDecl2.hs b/utils/check-exact/cases/AddDecl2.hs new file mode 100644 index 0000000000..45c0cb3864 --- /dev/null +++ b/utils/check-exact/cases/AddDecl2.hs @@ -0,0 +1,11 @@ +module AddDecl where + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +-- | Do bar +bar x y = {- baz -} foo (x+y) x + +-- end of file diff --git a/utils/check-exact/cases/AddDecl3.expected.hs b/utils/check-exact/cases/AddDecl3.expected.hs new file mode 100644 index 0000000000..dd3044fcc5 --- /dev/null +++ b/utils/check-exact/cases/AddDecl3.expected.hs @@ -0,0 +1,13 @@ +module AddDecl where + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +nn = n2 + +-- | Do bar +bar x y = {- baz -} foo (x+y) x + +-- end of file diff --git a/utils/check-exact/cases/AddDecl3.hs b/utils/check-exact/cases/AddDecl3.hs new file mode 100644 index 0000000000..45c0cb3864 --- /dev/null +++ b/utils/check-exact/cases/AddDecl3.hs @@ -0,0 +1,11 @@ +module AddDecl where + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +-- | Do bar +bar x y = {- baz -} foo (x+y) x + +-- end of file diff --git a/utils/check-exact/cases/AddHiding1.expected.hs b/utils/check-exact/cases/AddHiding1.expected.hs new file mode 100644 index 0000000000..f3c8f17c8b --- /dev/null +++ b/utils/check-exact/cases/AddHiding1.expected.hs @@ -0,0 +1,8 @@ +module AddHiding1 where + +import Data.Maybe hiding (n1,n2) + +import Data.Maybe hiding (n1,n2) + +f = 1 + diff --git a/utils/check-exact/cases/AddHiding1.hs b/utils/check-exact/cases/AddHiding1.hs new file mode 100644 index 0000000000..abcd47879a --- /dev/null +++ b/utils/check-exact/cases/AddHiding1.hs @@ -0,0 +1,8 @@ +module AddHiding1 where + +import Data.Maybe + +import Data.Maybe hiding (n1,n2) + +f = 1 + diff --git a/utils/check-exact/cases/AddHiding2.expected.hs b/utils/check-exact/cases/AddHiding2.expected.hs new file mode 100644 index 0000000000..d62005227b --- /dev/null +++ b/utils/check-exact/cases/AddHiding2.expected.hs @@ -0,0 +1,5 @@ +module AddHiding2 where + +import Data.Maybe hiding (f1,f2,n1,n2) + +f = 1 diff --git a/utils/check-exact/cases/AddHiding2.hs b/utils/check-exact/cases/AddHiding2.hs new file mode 100644 index 0000000000..f5f551a9cb --- /dev/null +++ b/utils/check-exact/cases/AddHiding2.hs @@ -0,0 +1,5 @@ +module AddHiding2 where + +import Data.Maybe hiding (f1,f2) + +f = 1 diff --git a/utils/check-exact/cases/AddLocalDecl1.expected.hs b/utils/check-exact/cases/AddLocalDecl1.expected.hs new file mode 100644 index 0000000000..023e2ea05d --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl1.expected.hs @@ -0,0 +1,15 @@ +module AddLocalDecl1 where + +-- |This is a function +foo = x -- comment1 + where + nn = 2 +-- trailing 1 + +-- |Another fun +x = a -- comment2 + where + a = 3 +-- trailing 2 + +y = 3 diff --git a/utils/check-exact/cases/AddLocalDecl1.hs b/utils/check-exact/cases/AddLocalDecl1.hs new file mode 100644 index 0000000000..3bb4953c51 --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl1.hs @@ -0,0 +1,13 @@ +module AddLocalDecl1 where + +-- |This is a function +foo = x -- comment1 +-- trailing 1 + +-- |Another fun +x = a -- comment2 + where + a = 3 +-- trailing 2 + +y = 3 diff --git a/utils/check-exact/cases/AddLocalDecl2.expected.hs b/utils/check-exact/cases/AddLocalDecl2.expected.hs new file mode 100644 index 0000000000..ff25b79157 --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl2.expected.hs @@ -0,0 +1,11 @@ +module AddLocalDecl2 where + +-- |This is a function +foo = x -- comment 0 + where nn = 2 + p = 2 -- comment 1 + +-- |Another fun +bar = a -- comment 2 + where nn = 2 + p = 2 -- comment 3 diff --git a/utils/check-exact/cases/AddLocalDecl2.hs b/utils/check-exact/cases/AddLocalDecl2.hs new file mode 100644 index 0000000000..7609f657ed --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl2.hs @@ -0,0 +1,10 @@ +module AddLocalDecl2 where + +-- |This is a function +foo = x -- comment 0 + where p = 2 -- comment 1 + +-- |Another fun +bar = a -- comment 2 + where nn = 2 + p = 2 -- comment 3 diff --git a/utils/check-exact/cases/AddLocalDecl3.expected.hs b/utils/check-exact/cases/AddLocalDecl3.expected.hs new file mode 100644 index 0000000000..deaf1e7cb8 --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl3.expected.hs @@ -0,0 +1,13 @@ +module AddLocalDecl3 where + +-- |This is a function +foo = x -- comment 0 + where p = 2 -- comment 1 + nn = 2 + -- comment f + +-- |Another fun +bar = a -- comment 2 + where p = 2 -- comment 3 + nn = 2 + -- comment b diff --git a/utils/check-exact/cases/AddLocalDecl3.hs b/utils/check-exact/cases/AddLocalDecl3.hs new file mode 100644 index 0000000000..eb14013031 --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl3.hs @@ -0,0 +1,12 @@ +module AddLocalDecl3 where + +-- |This is a function +foo = x -- comment 0 + where p = 2 -- comment 1 + -- comment f + +-- |Another fun +bar = a -- comment 2 + where p = 2 -- comment 3 + nn = 2 + -- comment b diff --git a/utils/check-exact/cases/AddLocalDecl4.expected.hs b/utils/check-exact/cases/AddLocalDecl4.expected.hs new file mode 100644 index 0000000000..b3c1445d0d --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl4.expected.hs @@ -0,0 +1,6 @@ +module AddLocalDecl4 where + +toplevel x = c * x + where + nn :: Int + nn = 2 diff --git a/utils/check-exact/cases/AddLocalDecl4.hs b/utils/check-exact/cases/AddLocalDecl4.hs new file mode 100644 index 0000000000..2ec2c0bf73 --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl4.hs @@ -0,0 +1,3 @@ +module AddLocalDecl4 where + +toplevel x = c * x diff --git a/utils/check-exact/cases/AddLocalDecl5.expected.hs b/utils/check-exact/cases/AddLocalDecl5.expected.hs new file mode 100644 index 0000000000..5e66dc5a6b --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl5.expected.hs @@ -0,0 +1,9 @@ +module AddLocalDecl5 where + +toplevel :: Integer -> Integer +toplevel x = c * x + where + -- c,d :: Integer + c = 7 + +d = 9 diff --git a/utils/check-exact/cases/AddLocalDecl5.hs b/utils/check-exact/cases/AddLocalDecl5.hs new file mode 100644 index 0000000000..9f07e1071b --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl5.hs @@ -0,0 +1,8 @@ +module AddLocalDecl5 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +-- c,d :: Integer +c = 7 +d = 9 diff --git a/utils/check-exact/cases/AddLocalDecl6.expected.hs b/utils/check-exact/cases/AddLocalDecl6.expected.hs new file mode 100644 index 0000000000..9cedb7d63f --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl6.expected.hs @@ -0,0 +1,12 @@ +module AddLocalDecl6 where + +foo [] = 1 -- comment 0 + where + x = 3 +foo xs = 2 -- comment 1 + +bar [] = 1 -- comment 2 + where + x = 3 +bar xs = 2 -- comment 3 + diff --git a/utils/check-exact/cases/AddLocalDecl6.hs b/utils/check-exact/cases/AddLocalDecl6.hs new file mode 100644 index 0000000000..d0bdffca41 --- /dev/null +++ b/utils/check-exact/cases/AddLocalDecl6.hs @@ -0,0 +1,10 @@ +module AddLocalDecl6 where + +foo [] = 1 -- comment 0 +foo xs = 2 -- comment 1 + +bar [] = 1 -- comment 2 + where + x = 3 +bar xs = 2 -- comment 3 + diff --git a/utils/check-exact/cases/EmptyWheres.hs b/utils/check-exact/cases/EmptyWheres.hs new file mode 100644 index 0000000000..edc0570012 --- /dev/null +++ b/utils/check-exact/cases/EmptyWheres.hs @@ -0,0 +1,9 @@ +module EmptyWheres where + +x = 2 where +y = 3 + +instance Foo1 Int where + +ff = ff where g = g where +type T = Int diff --git a/utils/check-exact/cases/LayoutIn1.expected.hs b/utils/check-exact/cases/LayoutIn1.expected.hs new file mode 100644 index 0000000000..2b23b21853 --- /dev/null +++ b/utils/check-exact/cases/LayoutIn1.expected.hs @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= square x + square y where sq x= x^pow + --There is a comment. + pow=2 diff --git a/utils/check-exact/cases/LayoutIn1.hs b/utils/check-exact/cases/LayoutIn1.hs new file mode 100644 index 0000000000..3ea1f8402c --- /dev/null +++ b/utils/check-exact/cases/LayoutIn1.hs @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= sq x + sq y where sq x= x^pow + --There is a comment. + pow=2 diff --git a/utils/check-exact/cases/LayoutIn3.expected.hs b/utils/check-exact/cases/LayoutIn3.expected.hs new file mode 100644 index 0000000000..900d6daf63 --- /dev/null +++ b/utils/check-exact/cases/LayoutIn3.expected.hs @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in (let y = 3 + z = 2 in anotherX * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/utils/check-exact/cases/LayoutIn3.hs b/utils/check-exact/cases/LayoutIn3.hs new file mode 100644 index 0000000000..c8c110d65c --- /dev/null +++ b/utils/check-exact/cases/LayoutIn3.hs @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in (let y = 3 + z = 2 in x * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/utils/check-exact/cases/LayoutIn3a.expected.hs b/utils/check-exact/cases/LayoutIn3a.expected.hs new file mode 100644 index 0000000000..c0a552c0d0 --- /dev/null +++ b/utils/check-exact/cases/LayoutIn3a.expected.hs @@ -0,0 +1,13 @@ +module LayoutIn3a where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in ( + anotherX ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/utils/check-exact/cases/LayoutIn3a.hs b/utils/check-exact/cases/LayoutIn3a.hs new file mode 100644 index 0000000000..58b36b07f8 --- /dev/null +++ b/utils/check-exact/cases/LayoutIn3a.hs @@ -0,0 +1,13 @@ +module LayoutIn3a where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in ( + x ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/utils/check-exact/cases/LayoutIn3b.expected.hs b/utils/check-exact/cases/LayoutIn3b.expected.hs new file mode 100644 index 0000000000..057d9d346a --- /dev/null +++ b/utils/check-exact/cases/LayoutIn3b.expected.hs @@ -0,0 +1,12 @@ +module LayoutIn3b where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in ( anotherX ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/utils/check-exact/cases/LayoutIn3b.hs b/utils/check-exact/cases/LayoutIn3b.hs new file mode 100644 index 0000000000..32bc294ae4 --- /dev/null +++ b/utils/check-exact/cases/LayoutIn3b.hs @@ -0,0 +1,12 @@ +module LayoutIn3b where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in ( x ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/utils/check-exact/cases/LayoutIn4.expected.hs b/utils/check-exact/cases/LayoutIn4.expected.hs new file mode 100644 index 0000000000..531478da48 --- /dev/null +++ b/utils/check-exact/cases/LayoutIn4.expected.hs @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = io "hello" where io s= do let k = reverse s +--There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/utils/check-exact/cases/LayoutIn4.hs b/utils/check-exact/cases/LayoutIn4.hs new file mode 100644 index 0000000000..d99d05649d --- /dev/null +++ b/utils/check-exact/cases/LayoutIn4.hs @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = ioFun "hello" where ioFun s= do let k = reverse s + --There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/utils/check-exact/cases/LayoutLet2.expected.hs b/utils/check-exact/cases/LayoutLet2.expected.hs new file mode 100644 index 0000000000..8da499ce3a --- /dev/null +++ b/utils/check-exact/cases/LayoutLet2.expected.hs @@ -0,0 +1,8 @@ +module LayoutLet2 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 in xxxlonger + a + b diff --git a/utils/check-exact/cases/LayoutLet2.hs b/utils/check-exact/cases/LayoutLet2.hs new file mode 100644 index 0000000000..378aa587a8 --- /dev/null +++ b/utils/check-exact/cases/LayoutLet2.hs @@ -0,0 +1,8 @@ +module LayoutLet2 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 in xxx + a + b diff --git a/utils/check-exact/cases/LayoutLet3.expected.hs b/utils/check-exact/cases/LayoutLet3.expected.hs new file mode 100644 index 0000000000..797cf5f483 --- /dev/null +++ b/utils/check-exact/cases/LayoutLet3.expected.hs @@ -0,0 +1,10 @@ +module LayoutLet3 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 + in xxxlonger + a + b + diff --git a/utils/check-exact/cases/LayoutLet3.hs b/utils/check-exact/cases/LayoutLet3.hs new file mode 100644 index 0000000000..5ba80aff6a --- /dev/null +++ b/utils/check-exact/cases/LayoutLet3.hs @@ -0,0 +1,10 @@ +module LayoutLet3 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + diff --git a/utils/check-exact/cases/LayoutLet4.expected.hs b/utils/check-exact/cases/LayoutLet4.expected.hs new file mode 100644 index 0000000000..b3c52f424e --- /dev/null +++ b/utils/check-exact/cases/LayoutLet4.expected.hs @@ -0,0 +1,12 @@ +module LayoutLet4 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 + in xxxlonger + a + b + +bar = 3 + diff --git a/utils/check-exact/cases/LayoutLet4.hs b/utils/check-exact/cases/LayoutLet4.hs new file mode 100644 index 0000000000..28fe599432 --- /dev/null +++ b/utils/check-exact/cases/LayoutLet4.hs @@ -0,0 +1,12 @@ +module LayoutLet4 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + +bar = 3 + diff --git a/utils/check-exact/cases/LetIn1.expected.hs b/utils/check-exact/cases/LetIn1.expected.hs new file mode 100644 index 0000000000..d233115ee6 --- /dev/null +++ b/utils/check-exact/cases/LetIn1.expected.hs @@ -0,0 +1,18 @@ +module LetIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the local 'pow' to 'sq' +--This example also aims to test the demoting a local declaration in 'let'. + +sumSquares x y = let sq 0=0 + sq z=z^pow + in sq x + sq y + + +anotherFun 0 y = sq y + where sq x = x^2 + + diff --git a/utils/check-exact/cases/LetIn1.hs b/utils/check-exact/cases/LetIn1.hs new file mode 100644 index 0000000000..f1109b8f03 --- /dev/null +++ b/utils/check-exact/cases/LetIn1.hs @@ -0,0 +1,19 @@ +module LetIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the local 'pow' to 'sq' +--This example also aims to test the demoting a local declaration in 'let'. + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + + +anotherFun 0 y = sq y + where sq x = x^2 + + diff --git a/utils/check-exact/cases/LocToName.expected.hs b/utils/check-exact/cases/LocToName.expected.hs new file mode 100644 index 0000000000..0b1484873a --- /dev/null +++ b/utils/check-exact/cases/LocToName.expected.hs @@ -0,0 +1,25 @@ +module LocToName where + +{- + + + + + + + + +-} + + + + + + + +LocToName.newPoint (x:xs) = x ^2 + LocToName.newPoint xs + -- where sq x = x ^pow + -- pow = 2 + +LocToName.newPoint [] = 0 + diff --git a/utils/check-exact/cases/LocToName.hs b/utils/check-exact/cases/LocToName.hs new file mode 100644 index 0000000000..89a0acea12 --- /dev/null +++ b/utils/check-exact/cases/LocToName.hs @@ -0,0 +1,25 @@ +module LocToName where + +{- + + + + + + + + +-} + + + + + + + +sumSquares (x:xs) = x ^2 + sumSquares xs + -- where sq x = x ^pow + -- pow = 2 + +sumSquares [] = 0 + diff --git a/utils/check-exact/cases/LocalDecls.expected.hs b/utils/check-exact/cases/LocalDecls.expected.hs new file mode 100644 index 0000000000..7c41178ba0 --- /dev/null +++ b/utils/check-exact/cases/LocalDecls.expected.hs @@ -0,0 +1,11 @@ +module LocalDecls where + +foo a = bar a + where + nn :: Int + nn = 2 + + bar :: Int -> Int + bar x = x + 2 + + baz = 4 diff --git a/utils/check-exact/cases/LocalDecls.hs b/utils/check-exact/cases/LocalDecls.hs new file mode 100644 index 0000000000..ebb774ac63 --- /dev/null +++ b/utils/check-exact/cases/LocalDecls.hs @@ -0,0 +1,8 @@ +module LocalDecls where + +foo a = bar a + where + bar :: Int -> Int + bar x = x + 2 + + baz = 4 diff --git a/utils/check-exact/cases/LocalDecls2.expected.hs b/utils/check-exact/cases/LocalDecls2.expected.hs new file mode 100644 index 0000000000..d2353e94c5 --- /dev/null +++ b/utils/check-exact/cases/LocalDecls2.expected.hs @@ -0,0 +1,8 @@ +module LocalDecls2 where + +foo a = bar a + where + nn :: Int + nn = 2 + + diff --git a/utils/check-exact/cases/LocalDecls2.hs b/utils/check-exact/cases/LocalDecls2.hs new file mode 100644 index 0000000000..92a8649649 --- /dev/null +++ b/utils/check-exact/cases/LocalDecls2.hs @@ -0,0 +1,3 @@ +module LocalDecls2 where + +foo a = bar a diff --git a/utils/check-exact/cases/Rename1.expected.hs b/utils/check-exact/cases/Rename1.expected.hs new file mode 100644 index 0000000000..353a7420e2 --- /dev/null +++ b/utils/check-exact/cases/Rename1.expected.hs @@ -0,0 +1,6 @@ +module Rename1 where + +bar2 x y = + do c <- getChar + return c + diff --git a/utils/check-exact/cases/Rename1.hs b/utils/check-exact/cases/Rename1.hs new file mode 100644 index 0000000000..1ad343afd3 --- /dev/null +++ b/utils/check-exact/cases/Rename1.hs @@ -0,0 +1,6 @@ +module Rename1 where + +foo x y = + do c <- getChar + return c + diff --git a/utils/check-exact/cases/Rename2.expected.hs b/utils/check-exact/cases/Rename2.expected.hs new file mode 100644 index 0000000000..6be3ff6e0a --- /dev/null +++ b/utils/check-exact/cases/Rename2.expected.hs @@ -0,0 +1,4 @@ + +joe x = case (odd x) of + True -> "Odd" + False -> "Even" diff --git a/utils/check-exact/cases/Rename2.hs b/utils/check-exact/cases/Rename2.hs new file mode 100644 index 0000000000..29fea060c2 --- /dev/null +++ b/utils/check-exact/cases/Rename2.hs @@ -0,0 +1,4 @@ + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" diff --git a/utils/check-exact/cases/RenameCase1.expected.hs b/utils/check-exact/cases/RenameCase1.expected.hs new file mode 100644 index 0000000000..dad6765012 --- /dev/null +++ b/utils/check-exact/cases/RenameCase1.expected.hs @@ -0,0 +1,5 @@ +module RenameCase1 where + +foo x = case (bazLonger x) of + 1 -> "a" + _ -> "b" diff --git a/utils/check-exact/cases/RenameCase1.hs b/utils/check-exact/cases/RenameCase1.hs new file mode 100644 index 0000000000..22d549367a --- /dev/null +++ b/utils/check-exact/cases/RenameCase1.hs @@ -0,0 +1,5 @@ +module RenameCase1 where + +foo x = case (baz x) of + 1 -> "a" + _ -> "b" diff --git a/utils/check-exact/cases/RmDecl1.expected.hs b/utils/check-exact/cases/RmDecl1.expected.hs new file mode 100644 index 0000000000..6bb503aede --- /dev/null +++ b/utils/check-exact/cases/RmDecl1.expected.hs @@ -0,0 +1,9 @@ +module RmDecl1 where + +sumSquares x = x * p + where p=2 {-There is a comment-} + +{- foo bar -} +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/RmDecl1.hs b/utils/check-exact/cases/RmDecl1.hs new file mode 100644 index 0000000000..15cd9f1e04 --- /dev/null +++ b/utils/check-exact/cases/RmDecl1.hs @@ -0,0 +1,13 @@ +module RmDecl1 where + +sumSquares x = x * p + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 +sq pow z = z^pow --there is a comment + +{- foo bar -} +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/RmDecl2.expected.hs b/utils/check-exact/cases/RmDecl2.expected.hs new file mode 100644 index 0000000000..d77b760dca --- /dev/null +++ b/utils/check-exact/cases/RmDecl2.expected.hs @@ -0,0 +1,9 @@ +module RmDecl2 where + +sumSquares x y = let sq 0=0 + sq z=z^pow + in sq x + sq y + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/RmDecl2.hs b/utils/check-exact/cases/RmDecl2.hs new file mode 100644 index 0000000000..2f0dbd3ace --- /dev/null +++ b/utils/check-exact/cases/RmDecl2.hs @@ -0,0 +1,10 @@ +module RmDecl2 where + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/RmDecl3.expected.hs b/utils/check-exact/cases/RmDecl3.expected.hs new file mode 100644 index 0000000000..ca14f33ad5 --- /dev/null +++ b/utils/check-exact/cases/RmDecl3.expected.hs @@ -0,0 +1,9 @@ +module RmDecl3 where + +-- Remove last declaration from a where clause, where should disappear too +ff y = y + zz + +zz = 1 + +foo = 3 +-- EOF diff --git a/utils/check-exact/cases/RmDecl3.hs b/utils/check-exact/cases/RmDecl3.hs new file mode 100644 index 0000000000..280bccf259 --- /dev/null +++ b/utils/check-exact/cases/RmDecl3.hs @@ -0,0 +1,9 @@ +module RmDecl3 where + +-- Remove last declaration from a where clause, where should disappear too +ff y = y + zz + where + zz = 1 + +foo = 3 +-- EOF diff --git a/utils/check-exact/cases/RmDecl4.expected.hs b/utils/check-exact/cases/RmDecl4.expected.hs new file mode 100644 index 0000000000..e7c71dbd08 --- /dev/null +++ b/utils/check-exact/cases/RmDecl4.expected.hs @@ -0,0 +1,10 @@ +module RmDecl4 where + +-- Remove first declaration from a where clause, last should still be indented +ff y = y + zz + xx + where + xx = 2 + +zz = 1 + +-- EOF diff --git a/utils/check-exact/cases/RmDecl4.hs b/utils/check-exact/cases/RmDecl4.hs new file mode 100644 index 0000000000..532b738763 --- /dev/null +++ b/utils/check-exact/cases/RmDecl4.hs @@ -0,0 +1,9 @@ +module RmDecl4 where + +-- Remove first declaration from a where clause, last should still be indented +ff y = y + zz + xx + where + zz = 1 + xx = 2 + +-- EOF diff --git a/utils/check-exact/cases/RmDecl5.expected.hs b/utils/check-exact/cases/RmDecl5.expected.hs new file mode 100644 index 0000000000..67ac8ddfab --- /dev/null +++ b/utils/check-exact/cases/RmDecl5.expected.hs @@ -0,0 +1,5 @@ +module RmDecl5 where + +sumSquares x y = let pow=2 + in sq x + sq y + diff --git a/utils/check-exact/cases/RmDecl5.hs b/utils/check-exact/cases/RmDecl5.hs new file mode 100644 index 0000000000..40f86199ce --- /dev/null +++ b/utils/check-exact/cases/RmDecl5.hs @@ -0,0 +1,7 @@ +module RmDecl5 where + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + diff --git a/utils/check-exact/cases/RmDecl6.expected.hs b/utils/check-exact/cases/RmDecl6.expected.hs new file mode 100644 index 0000000000..a2bd7d0443 --- /dev/null +++ b/utils/check-exact/cases/RmDecl6.expected.hs @@ -0,0 +1,9 @@ +module RmDecl6 where + +foo a = baz + where + x = 1 + + y :: Int -> Int -> Int + y a b = undefined + diff --git a/utils/check-exact/cases/RmDecl6.hs b/utils/check-exact/cases/RmDecl6.hs new file mode 100644 index 0000000000..cab5093ce8 --- /dev/null +++ b/utils/check-exact/cases/RmDecl6.hs @@ -0,0 +1,12 @@ +module RmDecl6 where + +foo a = baz + where + baz :: Int + baz = x + a + + x = 1 + + y :: Int -> Int -> Int + y a b = undefined + diff --git a/utils/check-exact/cases/RmDecl7.expected.hs b/utils/check-exact/cases/RmDecl7.expected.hs new file mode 100644 index 0000000000..9d7b8b9a69 --- /dev/null +++ b/utils/check-exact/cases/RmDecl7.expected.hs @@ -0,0 +1,7 @@ +module RmDecl7 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +d = 9 + diff --git a/utils/check-exact/cases/RmDecl7.hs b/utils/check-exact/cases/RmDecl7.hs new file mode 100644 index 0000000000..62cefe2154 --- /dev/null +++ b/utils/check-exact/cases/RmDecl7.hs @@ -0,0 +1,9 @@ +module RmDecl7 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +-- c,d :: Integer +c = 7 +d = 9 + diff --git a/utils/check-exact/cases/RmTypeSig1.expected.hs b/utils/check-exact/cases/RmTypeSig1.expected.hs new file mode 100644 index 0000000000..46f7b13399 --- /dev/null +++ b/utils/check-exact/cases/RmTypeSig1.expected.hs @@ -0,0 +1,8 @@ +module RmTypeSig1 where + +anotherFun :: Int -> Int +sq 0 = 0 +sq z = z^2 + +anotherFun x = x^2 + diff --git a/utils/check-exact/cases/RmTypeSig1.hs b/utils/check-exact/cases/RmTypeSig1.hs new file mode 100644 index 0000000000..498892d791 --- /dev/null +++ b/utils/check-exact/cases/RmTypeSig1.hs @@ -0,0 +1,8 @@ +module RmTypeSig1 where + +sq,anotherFun :: Int -> Int +sq 0 = 0 +sq z = z^2 + +anotherFun x = x^2 + diff --git a/utils/check-exact/cases/RmTypeSig2.expected.hs b/utils/check-exact/cases/RmTypeSig2.expected.hs new file mode 100644 index 0000000000..c30e201bd0 --- /dev/null +++ b/utils/check-exact/cases/RmTypeSig2.expected.hs @@ -0,0 +1,7 @@ +module RmTypeSig2 where + +-- Pattern bind +tup@(h,t) = (1,ff) + where + ff = 15 + diff --git a/utils/check-exact/cases/RmTypeSig2.hs b/utils/check-exact/cases/RmTypeSig2.hs new file mode 100644 index 0000000000..e8771f99dd --- /dev/null +++ b/utils/check-exact/cases/RmTypeSig2.hs @@ -0,0 +1,8 @@ +module RmTypeSig2 where + +-- Pattern bind +tup@(h,t) = (1,ff) + where + ff :: Int + ff = 15 + diff --git a/utils/check-exact/cases/WhereIn3a.expected.hs b/utils/check-exact/cases/WhereIn3a.expected.hs new file mode 100644 index 0000000000..acc94d3621 --- /dev/null +++ b/utils/check-exact/cases/WhereIn3a.expected.hs @@ -0,0 +1,20 @@ +module WhereIn3a where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/WhereIn3a.hs b/utils/check-exact/cases/WhereIn3a.hs new file mode 100644 index 0000000000..acc94d3621 --- /dev/null +++ b/utils/check-exact/cases/WhereIn3a.hs @@ -0,0 +1,20 @@ +module WhereIn3a where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/WhereIn3b.expected.hs b/utils/check-exact/cases/WhereIn3b.expected.hs new file mode 100644 index 0000000000..80ddc04825 --- /dev/null +++ b/utils/check-exact/cases/WhereIn3b.expected.hs @@ -0,0 +1,27 @@ +module WhereIn3a where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 + +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/WhereIn3b.hs b/utils/check-exact/cases/WhereIn3b.hs new file mode 100644 index 0000000000..acc94d3621 --- /dev/null +++ b/utils/check-exact/cases/WhereIn3b.hs @@ -0,0 +1,20 @@ +module WhereIn3a where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/WhereIn4.expected.hs b/utils/check-exact/cases/WhereIn4.expected.hs new file mode 100644 index 0000000000..4357bfdac7 --- /dev/null +++ b/utils/check-exact/cases/WhereIn4.expected.hs @@ -0,0 +1,19 @@ +module WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq p x + sq p y + where p_2=2 {-There is a comment-} + +sq::Int->Int->Int +sq pow z = z^pow --there is a comment + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/WhereIn4.hs b/utils/check-exact/cases/WhereIn4.hs new file mode 100644 index 0000000000..8b941fff4a --- /dev/null +++ b/utils/check-exact/cases/WhereIn4.hs @@ -0,0 +1,19 @@ +module WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq::Int->Int->Int +sq pow z = z^pow --there is a comment + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/utils/check-exact/cases/Windows.hs b/utils/check-exact/cases/Windows.hs new file mode 100644 index 0000000000..ad8ae692b6 --- /dev/null +++ b/utils/check-exact/cases/Windows.hs @@ -0,0 +1,10 @@ +module Windows where + +{- + This file has windows-style line endings, to check that trailing + \r's get stripped in comments. +-} +baz = 2 + +-- Another comment +foo = 1 diff --git a/utils/check-exact/check-exact.cabal b/utils/check-exact/check-exact.cabal new file mode 100644 index 0000000000..40188c094f --- /dev/null +++ b/utils/check-exact/check-exact.cabal @@ -0,0 +1,38 @@ +Name: check-exact +Version: 0.1 +Copyright: XXX +License: BSD3 +-- XXX License-File: LICENSE +Author: XXX +Maintainer: XXX +Synopsis: A utilities for checking the consistency of GHC's exact printer +Description: + This utility is used to check the consistency of the GHC exact + printer, by parsing a file, exact printing it, and then comparing + it to the original version. version. See + @utils/check-exact/README@ in GHC's source distribution for + details. +Category: Development +build-type: Simple +cabal-version: >=1.10 + +Executable check-exact + Default-Language: Haskell2010 + Main-Is: Main.hs + Ghc-Options: -Wall + other-modules: ExactPrint + Lookup + Parsers + Preprocess + Transform + Types + Utils + Build-Depends: base >= 4 && < 5, + bytestring, + containers, + Cabal >= 3.2 && < 3.6, + directory, + filepath, + ghc, + ghc-boot, + mtl diff --git a/utils/check-api-annotations/ghc.mk b/utils/check-exact/ghc.mk index 413d433ce5..f8ad02948b 100644 --- a/utils/check-api-annotations/ghc.mk +++ b/utils/check-exact/ghc.mk @@ -10,9 +10,9 @@ # # ----------------------------------------------------------------------------- -utils/check-api-annotations_USES_CABAL = YES -utils/check-api-annotations_PACKAGE = check-api-annotations -utils/check-api-annotations_dist-install_PROGNAME = check-api-annotations -utils/check-api-annotations_dist-install_INSTALL = NO -utils/check-api-annotations_dist-install_INSTALL_INPLACE = YES -$(eval $(call build-prog,utils/check-api-annotations,dist-install,2)) +utils/check-exact_USES_CABAL = YES +utils/check-exact_PACKAGE = check-exact +utils/check-exact_dist-install_PROGNAME = check-exact +utils/check-exact_dist-install_INSTALL = NO +utils/check-exact_dist-install_INSTALL_INPLACE = YES +$(eval $(call build-prog,utils/check-exact,dist-install,2)) diff --git a/utils/check-exact/run.sh b/utils/check-exact/run.sh new file mode 100755 index 0000000000..a4f0858128 --- /dev/null +++ b/utils/check-exact/run.sh @@ -0,0 +1,3 @@ +#!/bin/sh + +../../_build/stage1/bin/ghc --interactive diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs index 9d025633ef..0559e20f10 100644 --- a/utils/check-ppr/Main.hs +++ b/utils/check-ppr/Main.hs @@ -35,11 +35,11 @@ testOneFile libdir fileName = do p <- parseOneFile libdir fileName let origAst = showPprUnsafe - $ showAstData BlankSrcSpan + $ showAstData BlankSrcSpan BlankApiAnnotations $ eraseLayoutInfo (pm_parsed_source p) pped = pragmas ++ "\n" ++ pp (pm_parsed_source p) - anns = pm_annotations p - pragmas = getPragmas anns + anns' = pm_annotations p + pragmas = getPragmas anns' newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName astFile = fileName <.> "ast" @@ -52,7 +52,7 @@ testOneFile libdir fileName = do let newAstStr :: String newAstStr = showPprUnsafe - $ showAstData BlankSrcSpan + $ showAstData BlankSrcSpan BlankApiAnnotations $ eraseLayoutInfo (pm_parsed_source p') writeFile newAstFile newAstStr @@ -61,7 +61,7 @@ testOneFile libdir fileName = do -- putStrLn "ASTs matched" exitSuccess else do - putStrLn "AST Match Failed" + putStrLn "ppr AST Match Failed" putStrLn "\n===================================\nOrig\n\n" putStrLn origAst putStrLn "\n===================================\nNew\n\n" @@ -92,14 +92,15 @@ parseOneFile libdir fileName = do parseModule modSum getPragmas :: ApiAnns -> String -getPragmas anns = pragmaStr +getPragmas anns' = pragmaStr where - tokComment (L _ (AnnBlockComment s)) = s - tokComment (L _ (AnnLineComment s)) = s + tokComment (L _ (AnnComment (AnnBlockComment s) _)) = s + tokComment (L _ (AnnComment (AnnLineComment s) _)) = s tokComment _ = "" - comments = map tokComment $ sortRealLocated $ apiAnnRogueComments anns - pragmas = filter (\c -> isPrefixOf "{-#" c ) comments + cmp (L l1 _) (L l2 _) = compare (anchor l1) (anchor l2) + comments' = map tokComment $ sortBy cmp $ apiAnnRogueComments anns' + pragmas = filter (\c -> isPrefixOf "{-#" c ) comments' pragmaStr = intercalate "\n" pragmas pp :: (Outputable a) => a -> String diff --git a/utils/haddock b/utils/haddock -Subproject d930bd87cd43d840bf2877e4a51b2a48c2e18f7 +Subproject 3eb51fa32aaefe80bf2b6731dae2a2b26aba9e7 |